examples/Xlib-simple/Xlib.scm

   1 ;;;============================================================================
   2
   3 ;;; File: "Xlib.scm"
   4
   5 ;;; Copyright (c) 2006-2012 by Marc Feeley, All Rights Reserved.
   6
   7 ;;; A simple interface to the X Window System Xlib library.
   8
   9 ;; Note: This interface to Xlib is still in development.  There are
  10 ;;       still memory leaks in the interface.
  11
  12 ;;;============================================================================
  13
  14 (##namespace ("Xlib#"))
  15
  16 (##include "~~lib/gambit#.scm")
  17
  18 (##include "Xlib#.scm")
  19
  20 (declare
  21   (standard-bindings)
  22   (extended-bindings)
  23   (block)
  24   (not safe)
  25 )
  26
  27 ;;;============================================================================
  28
  29 (c-declare #<<end-of-c-declare
  30
  31 #include <X11/Xlib.h>
  32 #include <X11/Xutil.h>
  33
  34 end-of-c-declare
  35 )
  36
  37 ;; Declare a few types so that the function prototypes use the same
  38 ;; type names as a C program.
  39
  40 (c-define-type Time unsigned-long)
  41 (c-define-type XID unsigned-long)
  42
  43 (c-define-type Window XID)
  44 (c-define-type Drawable XID)
  45 (c-define-type Font XID)
  46 (c-define-type Pixmap XID)
  47 (c-define-type Cursor XID)
  48 (c-define-type Colormap XID)
  49 (c-define-type GContext XID)
  50 (c-define-type KeySym XID)
  51
  52 (c-declare #<<end-of-c-declare
  53
  54 #define debug_free_not
  55 #define really_free
  56
  57 #ifdef debug_free
  58 #include <stdio.h>
  59 #endif
  60
  61 ___SCMOBJ release_rc_XGCValues( void* ptr )
  62 { XGCValues* p = ptr;
  63 #ifdef debug_free
  64   printf( "release_rc_XGCValues(%p)\n", p );
  65   fflush( stdout );
  66 #endif
  67 #ifdef really_free
  68   ___EXT(___release_rc)( p );
  69 #endif
  70   return ___FIX(___NO_ERR);
  71 }
  72
  73 ___SCMOBJ XFreeFontInfo_XFontStruct( void* ptr )
  74 { XFontStruct* p = ptr;
  75 #ifdef debug_free
  76   printf( "XFreeFontInfo_XFontStruct(%p)\n", p );
  77   fflush( stdout );
  78 #endif
  79 #ifdef really_free
  80   XFreeFontInfo( NULL, p, 1 );
  81 #endif
  82   return ___FIX(___NO_ERR);
  83 }
  84
  85 ___SCMOBJ release_rc_XColor( void* ptr )
  86 { XColor* p = ptr;
  87 #ifdef debug_free
  88   printf( "release_rc_XColor(%p)\n", p );
  89   fflush( stdout );
  90 #endif
  91 #ifdef really_free
  92   ___EXT(___release_rc)( p );
  93 #endif
  94   return ___FIX(___NO_ERR);
  95 }
  96
  97 ___SCMOBJ release_rc_XEvent( void* ptr )
  98 { XEvent* p = ptr;
  99 #ifdef debug_free
 100   printf( "release_rc_XEvent(%p)\n", p );
 101   fflush( stdout );
 102 #endif
 103 #ifdef really_free
 104   ___EXT(___release_rc)( p );
 105 #endif
 106   return ___FIX(___NO_ERR);
 107 }
 108
 109 end-of-c-declare
 110 )
 111
 112 (c-define-type Bool int)
 113 (c-define-type Status int)
 114 (c-define-type GC (pointer (struct "_XGC") (GC)))
 115 (c-define-type Visual "Visual")
 116 (c-define-type Visual* (pointer Visual (Visual*)))
 117 (c-define-type Display "Display")
 118 (c-define-type Display* (pointer Display (Display*)))
 119 (c-define-type Screen "Screen")
 120 (c-define-type Screen* (pointer Screen (Screen*)))
 121 (c-define-type XGCValues "XGCValues")
 122 (c-define-type XGCValues* (pointer XGCValues (XGCValues*)))
 123 (c-define-type XGCValues*/release-rc (pointer XGCValues (XGCValues*) "release_rc_XGCValues"))
 124 (c-define-type XFontStruct "XFontStruct")
 125 (c-define-type XFontStruct* (pointer XFontStruct (XFontStruct*)))
 126 (c-define-type XFontStruct*/XFreeFontInfo (pointer XFontStruct (XFontStruct*) "XFreeFontInfo_XFontStruct"))
 127 (c-define-type XColor "XColor")
 128 (c-define-type XColor* (pointer XColor (XColor*)))
 129 (c-define-type XColor*/release-rc (pointer XColor (XColor*) "release_rc_XColor"))
 130 (c-define-type XEvent "XEvent")
 131 (c-define-type XEvent* (pointer XEvent (XEvent*)))
 132 (c-define-type XEvent*/release-rc (pointer XEvent (XEvent*) "release_rc_XEvent"))
 133
 134 (c-define-type char* char-string)
 135
 136 ;; Function prototypes for a minimal subset of Xlib functions.  The
 137 ;; functions have the same name in Scheme and C.
 138
 139 (define XOpenDisplay
 140   (c-lambda (char*)        ;; display_name
 141             Display*
 142             "XOpenDisplay"))
 143
 144 (define XCloseDisplay
 145   (c-lambda (Display*)     ;; display
 146             int
 147             "XCloseDisplay"))
 148
 149 (define XDefaultScreen
 150   (c-lambda (Display*)     ;; display
 151             int
 152             "XDefaultScreen"))
 153
 154 (define XScreenOfDisplay
 155   (c-lambda (Display*      ;; display
 156              int)          ;; screen_number
 157             Screen*
 158             "XScreenOfDisplay"))
 159
 160 (define XDefaultColormapOfScreen
 161   (c-lambda (Screen*)      ;; screen
 162             Colormap
 163             "XDefaultColormapOfScreen"))
 164
 165 (define XClearWindow
 166   (c-lambda (Display*      ;; display
 167              Window)       ;; w
 168             int
 169             "XClearWindow"))
 170
 171 (define XConnectionNumber
 172   (c-lambda (Display*)     ;; display
 173             int
 174             "XConnectionNumber"))
 175
 176 (define XRootWindow
 177   (c-lambda (Display*      ;; display
 178              int)          ;; screen_number
 179             Window
 180             "XRootWindow"))
 181
 182 (define XDefaultRootWindow
 183   (c-lambda (Display*)     ;; display
 184             Window
 185             "XDefaultRootWindow"))
 186
 187 (define XRootWindowOfScreen
 188   (c-lambda (Screen*)      ;; screen
 189             Window
 190             "XRootWindowOfScreen"))
 191
 192 (define XDefaultVisual
 193   (c-lambda (Display*      ;; display
 194              int)          ;; screen_number
 195             Visual*
 196             "XDefaultVisual"))
 197
 198 (define XDefaultVisualOfScreen
 199   (c-lambda (Screen*)      ;; screen
 200             Visual*
 201             "XDefaultVisualOfScreen"))
 202
 203 (define XDefaultGC
 204   (c-lambda (Display*      ;; display
 205              int)          ;; screen_number
 206             GC
 207             "XDefaultGC"))
 208
 209 (define XDefaultGCOfScreen
 210   (c-lambda (Screen*)      ;; screen
 211             GC
 212             "XDefaultGCOfScreen"))
 213
 214 (define XBlackPixel
 215   (c-lambda (Display*       ;; display
 216              int)           ;; screen_number
 217             unsigned-long
 218             "XBlackPixel"))
 219
 220 (define XWhitePixel
 221   (c-lambda (Display*       ;; display
 222              int)           ;; screen_number
 223             unsigned-long
 224             "XWhitePixel"))
 225
 226 (define XCreateSimpleWindow
 227   (c-lambda (Display*       ;; display
 228              Window         ;; parent
 229              int            ;; x
 230              int            ;; y
 231              unsigned-int   ;; width
 232              unsigned-int   ;; height
 233              unsigned-int   ;; border_width
 234              unsigned-long  ;; border
 235              unsigned-long) ;; backgound
 236             Window
 237             "XCreateSimpleWindow"))
 238
 239 (define XMapWindow
 240   (c-lambda (Display*       ;; display
 241              Window)        ;; w
 242             int
 243             "XMapWindow"))
 244
 245 (define XResizeWindow
 246   (c-lambda (Display*       ;; display
 247              Window         ;; w
 248              unsigned-int   ;; width
 249              unsigned-int)  ;; height
 250             int
 251             "XResizeWindow"))
 252
 253 (define XFlush
 254   (c-lambda (Display*)      ;; display
 255             int
 256             "XFlush"))
 257
 258 (define XCreateGC
 259   (c-lambda (Display*       ;; display
 260              Drawable       ;; d
 261              unsigned-long  ;; valuemask
 262              XGCValues*)    ;; values
 263             GC
 264             "XCreateGC"))
 265
 266 (define XFreeGC
 267   (c-lambda (Display*       ;; display
 268              GC)            ;; gc
 269             int
 270             "XFreeGC"))
 271
 272 (define XFillRectangle
 273   (c-lambda (Display*      ;; display
 274              Drawable      ;; d
 275              GC            ;; gc
 276              int           ;; x
 277              int           ;; y
 278              unsigned-int  ;; width
 279              unsigned-int) ;; height
 280             int
 281             "XFillRectangle"))
 282
 283 (define XFillArc
 284   (c-lambda (Display*      ;; display
 285              Drawable      ;; d
 286              GC            ;; gc
 287              int           ;; x
 288              int           ;; y
 289              unsigned-int  ;; width
 290              unsigned-int  ;; height
 291              int           ;; angle1
 292              int)          ;; angle2
 293             int
 294             "XFillArc"))
 295
 296 (define XDrawString
 297   (c-lambda (Display*      ;; display
 298              Drawable      ;; d
 299              GC            ;; gc
 300              int           ;; x
 301              int           ;; y
 302              char*         ;; string
 303              int)          ;; length
 304             int
 305             "XDrawString"))
 306
 307 (define XTextWidth
 308   (c-lambda (XFontStruct*  ;; font_struct
 309              char*         ;; string
 310              int)          ;; count
 311             int
 312             "XTextWidth"))
 313
 314 (define XParseColor
 315   (c-lambda (Display*      ;; display
 316              Colormap      ;; colormap
 317              char*         ;; spec
 318              XColor*)      ;; exact_def_return
 319             Status
 320             "XParseColor"))
 321
 322 (define XAllocColor
 323   (c-lambda (Display*      ;; display
 324              Colormap      ;; colormap
 325              XColor*)      ;; screen_in_out
 326             Status
 327             "XAllocColor"))
 328
 329 (define (make-XColor-box)
 330   ((c-lambda ()
 331              XColor*/release-rc
 332              "___result_voidstar = ___EXT(___alloc_rc) (sizeof (XColor));")))
 333
 334 (define XColor-pixel
 335   (c-lambda (XColor*)       ;; XColor box
 336              unsigned-long
 337             "___result = ___arg1->pixel;"))
 338
 339 (define XColor-pixel-set!
 340   (c-lambda (XColor*        ;; XColor box
 341              unsigned-long) ;; intensity
 342             void
 343             "___arg1->pixel = ___arg2;"))
 344
 345 (define XColor-red
 346   (c-lambda (XColor*)       ;; XColor box
 347              unsigned-short
 348             "___result = ___arg1->red;"))
 349
 350 (define XColor-red-set!
 351   (c-lambda (XColor*        ;; XColor box
 352              unsigned-short);; intensity
 353             void
 354             "___arg1->red = ___arg2;"))
 355
 356 (define XColor-green
 357   (c-lambda (XColor*)       ;; XColor box
 358              unsigned-short
 359             "___result = ___arg1->green;"))
 360
 361 (define XColor-green-set!
 362   (c-lambda (XColor*        ;; XColor box
 363              unsigned-short);; intensity
 364             void
 365             "___arg1->green = ___arg2;"))
 366
 367 (define XColor-blue
 368   (c-lambda (XColor*)       ;; XColor box
 369              unsigned-short
 370             "___result = ___arg1->blue;"))
 371
 372 (define XColor-blue-set!
 373   (c-lambda (XColor*        ;; XColor box
 374              unsigned-short);; intensity
 375             void
 376             "___arg1->blue = ___arg2;"))
 377
 378 (define (make-XGCValues-box)
 379   ((c-lambda ()
 380              XGCValues*/release-rc
 381              "___result_voidstar = ___EXT(___alloc_rc) (sizeof (XGCValues));")))
 382
 383 (define XGCValues-foreground
 384   (c-lambda (XGCValues*)    ;; XGCValues box
 385             unsigned-long
 386             "return ___arg1->foreground;"))
 387
 388 (define XGCValues-foreground-set!
 389   (c-lambda (XGCValues*     ;; XGCValues box
 390              unsigned-long) ;; pixel index
 391             void
 392             "___arg1->foreground = ___arg2;"))
 393
 394 (define XGCValues-background
 395   (c-lambda (XGCValues*)    ;; XGCValues box
 396             unsigned-long
 397             "return ___arg1->background;"))
 398
 399 (define XGCValues-background-set!
 400   (c-lambda (XGCValues*     ;; XGCValues box
 401              unsigned-long) ;; pixel index
 402             void
 403             "___arg1->background = ___arg2;"))
 404
 405 (define XGCValues-font
 406   (c-lambda (XGCValues*)    ;; XGCValues box
 407             Font
 408             "return ___arg1->font;"))
 409
 410 (define XGCValues-font-set!
 411   (c-lambda (XGCValues*     ;; XGCValues box
 412              Font)          ;; font_ID
 413             void
 414             "___arg1->font = ___arg2;"))
 415
 416 (define GCFunction
 417   ((c-lambda () unsigned-long "___result = GCFunction;")))
 418
 419 (define GCPlaneMask
 420   ((c-lambda () unsigned-long "___result = GCPlaneMask;")))
 421
 422 (define GCForeground
 423   ((c-lambda () unsigned-long "___result = GCForeground;")))
 424
 425 (define GCBackground
 426   ((c-lambda () unsigned-long "___result = GCBackground;")))
 427
 428 (define GCLineWidth
 429   ((c-lambda () unsigned-long "___result = GCLineWidth;")))
 430
 431 (define GCLineStyle
 432   ((c-lambda () unsigned-long "___result = GCLineStyle;")))
 433
 434 (define GCCapStyle
 435   ((c-lambda () unsigned-long "___result = GCCapStyle;")))
 436
 437 (define GCJoinStyle
 438   ((c-lambda () unsigned-long "___result = GCJoinStyle;")))
 439
 440 (define GCFillStyle
 441   ((c-lambda () unsigned-long "___result = GCFillStyle;")))
 442
 443 (define GCFillRule
 444   ((c-lambda () unsigned-long "___result = GCFillRule;")))
 445
 446 (define GCTile
 447   ((c-lambda () unsigned-long "___result = GCTile;")))
 448
 449 (define GCStipple
 450   ((c-lambda () unsigned-long "___result = GCStipple;")))
 451
 452 (define GCTileStipXOrigin
 453   ((c-lambda () unsigned-long "___result = GCTileStipXOrigin;")))
 454
 455 (define GCTileStipYOrigin
 456   ((c-lambda () unsigned-long "___result = GCTileStipYOrigin;")))
 457
 458 (define GCFont
 459   ((c-lambda () unsigned-long "___result = GCFont;")))
 460
 461 (define GCSubwindowMode
 462   ((c-lambda () unsigned-long "___result = GCSubwindowMode;")))
 463
 464 (define GCGraphicsExposures
 465   ((c-lambda () unsigned-long "___result = GCGraphicsExposures;")))
 466
 467 (define GCClipXOrigin
 468   ((c-lambda () unsigned-long "___result = GCClipXOrigin;")))
 469
 470 (define GCClipYOrigin
 471   ((c-lambda () unsigned-long "___result = GCClipYOrigin;")))
 472
 473 (define GCClipMask
 474   ((c-lambda () unsigned-long "___result = GCClipMask;")))
 475
 476 (define GCDashOffset
 477   ((c-lambda () unsigned-long "___result = GCDashOffset;")))
 478
 479 (define GCDashList
 480   ((c-lambda () unsigned-long "___result = GCDashList;")))
 481
 482 (define GCArcMode
 483   ((c-lambda () unsigned-long "___result = GCArcMode;")))
 484
 485 (define XChangeGC
 486   (c-lambda (Display*       ;; display
 487              GC             ;; gc
 488              unsigned-long  ;; valuemask
 489              XGCValues*)    ;; values
 490             int
 491             "XChangeGC"))
 492
 493 (define XGetGCValues
 494   (c-lambda (Display*       ;; display
 495              GC             ;; gc
 496              unsigned-long  ;; valuemask
 497              XGCValues*)    ;; values_return
 498             int
 499             "XGetGCValues"))
 500
 501 (define XQueryFont
 502   (c-lambda (Display*       ;; display
 503              Font)          ;; font_ID
 504             XFontStruct*/XFreeFontInfo
 505             "XQueryFont"))
 506
 507 (define XFreeFontInfo
 508   (c-lambda (nonnull-char-string-list ;; names
 509              XFontStruct*             ;; free_info
 510              int)                     ;; actual_count
 511             int
 512             "XFreeFontInfo"))
 513
 514 (define XLoadFont
 515   (c-lambda (Display*       ;; display
 516              char*)         ;; name
 517             Font
 518             "XLoadFont"))
 519
 520 (define XUnloadFont
 521   (c-lambda (Display*       ;; display
 522              Font)          ;; font
 523             int
 524             "XUnloadFont"))
 525
 526 (define XLoadQueryFont
 527   (c-lambda (Display*       ;; display
 528              char*)         ;; name
 529             XFontStruct*/XFreeFontInfo
 530             "XLoadQueryFont"))
 531
 532 (define XFreeFont
 533   (c-lambda (Display*       ;; display
 534              XFontStruct*)  ;; font_struct
 535             int
 536             "XFreeFont"))
 537
 538 (define XFontStruct-fid
 539   (c-lambda (XFontStruct*)  ;; font_struct
 540             Font
 541             "___result = ___arg1->fid;"))
 542
 543 (define XFontStruct-ascent
 544   (c-lambda (XFontStruct*)  ;; font_struct
 545             int
 546             "___result = ___arg1->ascent;"))
 547
 548 (define XFontStruct-descent
 549   (c-lambda (XFontStruct*)  ;; font_struct
 550             int
 551             "___result = ___arg1->descent;"))
 552
 553 (define NoEventMask
 554   ((c-lambda () long "___result = NoEventMask;")))
 555
 556 (define KeyPressMask
 557   ((c-lambda () long "___result = KeyPressMask;")))
 558
 559 (define KeyReleaseMask
 560   ((c-lambda () long "___result = KeyReleaseMask;")))
 561
 562 (define ButtonPressMask
 563   ((c-lambda () long "___result = ButtonPressMask;")))
 564
 565 (define ButtonReleaseMask
 566   ((c-lambda () long "___result = ButtonReleaseMask;")))
 567
 568 (define EnterWindowMask
 569   ((c-lambda () long "___result = EnterWindowMask;")))
 570
 571 (define LeaveWindowMask
 572   ((c-lambda () long "___result = LeaveWindowMask;")))
 573
 574 (define PointerMotionMask
 575   ((c-lambda () long "___result = PointerMotionMask;")))
 576
 577 (define PointerMotionHintMask
 578   ((c-lambda () long "___result = PointerMotionHintMask;")))
 579
 580 (define Button1MotionMask
 581   ((c-lambda () long "___result = Button1MotionMask;")))
 582
 583 (define Button2MotionMask
 584   ((c-lambda () long "___result = Button2MotionMask;")))
 585
 586 (define Button3MotionMask
 587   ((c-lambda () long "___result = Button3MotionMask;")))
 588
 589 (define Button4MotionMask
 590   ((c-lambda () long "___result = Button4MotionMask;")))
 591
 592 (define Button5MotionMask
 593   ((c-lambda () long "___result = Button5MotionMask;")))
 594
 595 (define ButtonMotionMask
 596   ((c-lambda () long "___result = ButtonMotionMask;")))
 597
 598 (define KeymapStateMask
 599   ((c-lambda () long "___result = KeymapStateMask;")))
 600
 601 (define ExposureMask
 602   ((c-lambda () long "___result = ExposureMask;")))
 603
 604 (define VisibilityChangeMask
 605   ((c-lambda () long "___result = VisibilityChangeMask;")))
 606
 607 (define StructureNotifyMask
 608   ((c-lambda () long "___result = StructureNotifyMask;")))
 609
 610 (define ResizeRedirectMask
 611   ((c-lambda () long "___result = ResizeRedirectMask;")))
 612
 613 (define SubstructureNotifyMask
 614   ((c-lambda () long "___result = SubstructureNotifyMask;")))
 615
 616 (define SubstructureRedirectMask
 617   ((c-lambda () long "___result = SubstructureRedirectMask;")))
 618
 619 (define FocusChangeMask
 620   ((c-lambda () long "___result = FocusChangeMask;")))
 621
 622 (define PropertyChangeMask
 623   ((c-lambda () long "___result = PropertyChangeMask;")))
 624
 625 (define ColormapChangeMask
 626   ((c-lambda () long "___result = ColormapChangeMask;")))
 627
 628 (define OwnerGrabButtonMask
 629   ((c-lambda () long "___result = OwnerGrabButtonMask;")))
 630
 631 (define KeyPress
 632   ((c-lambda () long "___result = KeyPress;")))
 633
 634 (define KeyRelease
 635   ((c-lambda () long "___result = KeyRelease;")))
 636
 637 (define ButtonPress
 638   ((c-lambda () long "___result = ButtonPress;")))
 639
 640 (define ButtonRelease
 641   ((c-lambda () long "___result = ButtonRelease;")))
 642
 643 (define MotionNotify
 644   ((c-lambda () long "___result = MotionNotify;")))
 645
 646 (define EnterNotify
 647   ((c-lambda () long "___result = EnterNotify;")))
 648
 649 (define LeaveNotify
 650   ((c-lambda () long "___result = LeaveNotify;")))
 651
 652 (define FocusIn
 653   ((c-lambda () long "___result = FocusIn;")))
 654
 655 (define FocusOut
 656   ((c-lambda () long "___result = FocusOut;")))
 657
 658 (define KeymapNotify
 659   ((c-lambda () long "___result = KeymapNotify;")))
 660
 661 (define Expose
 662   ((c-lambda () long "___result = Expose;")))
 663
 664 (define GraphicsExpose
 665   ((c-lambda () long "___result = GraphicsExpose;")))
 666
 667 (define NoExpose
 668   ((c-lambda () long "___result = NoExpose;")))
 669
 670 (define VisibilityNotify
 671   ((c-lambda () long "___result = VisibilityNotify;")))
 672
 673 (define CreateNotify
 674   ((c-lambda () long "___result = CreateNotify;")))
 675
 676 (define DestroyNotify
 677   ((c-lambda () long "___result = DestroyNotify;")))
 678
 679 (define UnmapNotify
 680   ((c-lambda () long "___result = UnmapNotify;")))
 681
 682 (define MapNotify
 683   ((c-lambda () long "___result = MapNotify;")))
 684
 685 (define MapRequest
 686   ((c-lambda () long "___result = MapRequest;")))
 687
 688 (define ReparentNotify
 689   ((c-lambda () long "___result = ReparentNotify;")))
 690
 691 (define ConfigureNotify
 692   ((c-lambda () long "___result = ConfigureNotify;")))
 693
 694 (define ConfigureRequest
 695   ((c-lambda () long "___result = ConfigureRequest;")))
 696
 697 (define GravityNotify
 698   ((c-lambda () long "___result = GravityNotify;")))
 699
 700 (define ResizeRequest
 701   ((c-lambda () long "___result = ResizeRequest;")))
 702
 703 (define CirculateNotify
 704   ((c-lambda () long "___result = CirculateNotify;")))
 705
 706 (define CirculateRequest
 707   ((c-lambda () long "___result = CirculateRequest;")))
 708
 709 (define PropertyNotify
 710   ((c-lambda () long "___result = PropertyNotify;")))
 711
 712 (define SelectionClear
 713   ((c-lambda () long "___result = SelectionClear;")))
 714
 715 (define SelectionRequest
 716   ((c-lambda () long "___result = SelectionRequest;")))
 717
 718 (define SelectionNotify
 719   ((c-lambda () long "___result = SelectionNotify;")))
 720
 721 (define ColormapNotify
 722   ((c-lambda () long "___result = ColormapNotify;")))
 723
 724 (define ClientMessage
 725   ((c-lambda () long "___result = ClientMessage;")))
 726
 727 (define MappingNotify
 728   ((c-lambda () long "___result = MappingNotify;")))
 729
 730 (define XCheckMaskEvent
 731   (c-lambda (Display*       ;; display
 732              long)          ;; event_mask
 733             XEvent*/release-rc
 734 #<<end-of-c-lambda
 735 XEvent ev;
 736 XEvent* pev;
 737 if (XCheckMaskEvent (___arg1, ___arg2, &ev))
 738   {
 739     pev = ___CAST(XEvent*,___EXT(___alloc_rc) (sizeof (ev)));
 740     *pev = ev;
 741   }
 742 else
 743   pev = 0;
 744 ___result_voidstar = pev;
 745 end-of-c-lambda
 746 ))
 747
 748 (define XSelectInput
 749   (c-lambda (Display*       ;; display
 750              Window         ;; w
 751              long)          ;; event_mask
 752             int
 753             "XSelectInput"))
 754
 755 (define XAnyEvent-type
 756   (c-lambda (XEvent*)       ;; XEvent box
 757             int
 758             "___result = ___arg1->type;"))
 759
 760 (define XAnyEvent-serial
 761   (c-lambda (XEvent*)       ;; XEvent box
 762             unsigned-long
 763             "___result = ___arg1->xany.serial;"))
 764
 765 (define XAnyEvent-send-event
 766   (c-lambda (XEvent*)       ;; XEvent box
 767             bool
 768             "___result = ___arg1->xany.send_event;"))
 769
 770 (define XAnyEvent-display
 771   (c-lambda (XEvent*)       ;; XEvent box
 772             Display*
 773             "___result_voidstar = ___arg1->xany.display;"))
 774
 775 (define XAnyEvent-window
 776   (c-lambda (XEvent*)       ;; XEvent box
 777             Window
 778             "___result = ___arg1->xany.window;"))
 779
 780 (define XKeyEvent-root
 781   (c-lambda (XEvent*)       ;; XEvent box
 782             Window
 783             "___result = ___arg1->xkey.root;"))
 784
 785 (define XKeyEvent-subwindow
 786   (c-lambda (XEvent*)       ;; XEvent box
 787             Window
 788             "___result = ___arg1->xkey.subwindow;"))
 789
 790 (define XKeyEvent-time
 791   (c-lambda (XEvent*)       ;; XEvent box
 792             Time
 793             "___result = ___arg1->xkey.time;"))
 794
 795 (define XKeyEvent-x
 796   (c-lambda (XEvent*)       ;; XEvent box
 797             int
 798             "___result = ___arg1->xkey.x;"))
 799
 800 (define XKeyEvent-y
 801   (c-lambda (XEvent*)       ;; XEvent box
 802             int
 803             "___result = ___arg1->xkey.y;"))
 804
 805 (define XKeyEvent-x-root
 806   (c-lambda (XEvent*)       ;; XEvent box
 807             int
 808             "___result = ___arg1->xkey.x_root;"))
 809
 810 (define XKeyEvent-y-root
 811   (c-lambda (XEvent*)       ;; XEvent box
 812             int
 813             "___result = ___arg1->xkey.y_root;"))
 814
 815 (define XKeyEvent-state
 816   (c-lambda (XEvent*)       ;; XEvent box
 817             unsigned-int
 818             "___result = ___arg1->xkey.state;"))
 819
 820 (define XKeyEvent-keycode
 821   (c-lambda (XEvent*)       ;; XEvent box
 822             unsigned-int
 823             "___result = ___arg1->xkey.keycode;"))
 824
 825 (define XKeyEvent-same-screen
 826   (c-lambda (XEvent*)       ;; XEvent box
 827             bool
 828             "___result = ___arg1->xkey.same_screen;"))
 829
 830 (define XButtonEvent-root
 831   (c-lambda (XEvent*)       ;; XEvent box
 832             Window
 833             "___result = ___arg1->xbutton.root;"))
 834
 835 (define XButtonEvent-subwindow
 836   (c-lambda (XEvent*)       ;; XEvent box
 837             Window
 838             "___result = ___arg1->xbutton.subwindow;"))
 839
 840 (define XButtonEvent-time
 841   (c-lambda (XEvent*)       ;; XEvent box
 842             Time
 843             "___result = ___arg1->xbutton.time;"))
 844
 845 (define XButtonEvent-x
 846   (c-lambda (XEvent*)       ;; XEvent box
 847             int
 848             "___result = ___arg1->xbutton.x;"))
 849
 850 (define XButtonEvent-y
 851   (c-lambda (XEvent*)       ;; XEvent box
 852             int
 853             "___result = ___arg1->xbutton.y;"))
 854
 855 (define XButtonEvent-x-root
 856   (c-lambda (XEvent*)       ;; XEvent box
 857             int
 858             "___result = ___arg1->xbutton.x_root;"))
 859
 860 (define XButtonEvent-y-root
 861   (c-lambda (XEvent*)       ;; XEvent box
 862             int
 863             "___result = ___arg1->xbutton.y_root;"))
 864
 865 (define XButtonEvent-state
 866   (c-lambda (XEvent*)       ;; XEvent box
 867             unsigned-int
 868             "___result = ___arg1->xbutton.state;"))
 869
 870 (define XButtonEvent-button
 871   (c-lambda (XEvent*)       ;; XEvent box
 872             unsigned-int
 873             "___result = ___arg1->xbutton.button;"))
 874
 875 (define XButtonEvent-same-screen
 876   (c-lambda (XEvent*)       ;; XEvent box
 877             bool
 878             "___result = ___arg1->xbutton.same_screen;"))
 879
 880 (define XMotionEvent-root
 881   (c-lambda (XEvent*)       ;; XEvent box
 882             Window
 883             "___result = ___arg1->xmotion.root;"))
 884
 885 (define XMotionEvent-subwindow
 886   (c-lambda (XEvent*)       ;; XEvent box
 887             Window
 888             "___result = ___arg1->xmotion.subwindow;"))
 889
 890 (define XMotionEvent-time
 891   (c-lambda (XEvent*)       ;; XEvent box
 892             Time
 893             "___result = ___arg1->xmotion.time;"))
 894
 895 (define XMotionEvent-x
 896   (c-lambda (XEvent*)       ;; XEvent box
 897             int
 898             "___result = ___arg1->xmotion.x;"))
 899
 900 (define XMotionEvent-y
 901   (c-lambda (XEvent*)       ;; XEvent box
 902             int
 903             "___result = ___arg1->xmotion.y;"))
 904
 905 (define XMotionEvent-x-root
 906   (c-lambda (XEvent*)       ;; XEvent box
 907             int
 908             "___result = ___arg1->xmotion.x_root;"))
 909
 910 (define XMotionEvent-y-root
 911   (c-lambda (XEvent*)       ;; XEvent box
 912             int
 913             "___result = ___arg1->xmotion.y_root;"))
 914
 915 (define XMotionEvent-state
 916   (c-lambda (XEvent*)       ;; XEvent box
 917             unsigned-int
 918             "___result = ___arg1->xmotion.state;"))
 919
 920 (define XMotionEvent-is-hint
 921   (c-lambda (XEvent*)       ;; XEvent box
 922             char
 923             "___result = ___arg1->xmotion.is_hint;"))
 924
 925 (define XMotionEvent-same-screen
 926   (c-lambda (XEvent*)       ;; XEvent box
 927             bool
 928             "___result = ___arg1->xmotion.same_screen;"))
 929
 930 (define XCrossingEvent-root
 931   (c-lambda (XEvent*)       ;; XEvent box
 932             Window
 933             "___result = ___arg1->xcrossing.root;"))
 934
 935 (define XCrossingEvent-subwindow
 936   (c-lambda (XEvent*)       ;; XEvent box
 937             Window
 938             "___result = ___arg1->xcrossing.subwindow;"))
 939
 940 (define XCrossingEvent-time
 941   (c-lambda (XEvent*)       ;; XEvent box
 942             Time
 943             "___result = ___arg1->xcrossing.time;"))
 944
 945 (define XCrossingEvent-x
 946   (c-lambda (XEvent*)       ;; XEvent box
 947             int
 948             "___result = ___arg1->xcrossing.x;"))
 949
 950 (define XCrossingEvent-y
 951   (c-lambda (XEvent*)       ;; XEvent box
 952             int
 953             "___result = ___arg1->xcrossing.y;"))
 954
 955 (define XCrossingEvent-x-root
 956   (c-lambda (XEvent*)       ;; XEvent box
 957             int
 958             "___result = ___arg1->xcrossing.x_root;"))
 959
 960 (define XCrossingEvent-y-root
 961   (c-lambda (XEvent*)       ;; XEvent box
 962             int
 963             "___result = ___arg1->xcrossing.y_root;"))
 964
 965 (define XCrossingEvent-mode
 966   (c-lambda (XEvent*)       ;; XEvent box
 967             int
 968             "___result = ___arg1->xcrossing.mode;"))
 969
 970 (define XCrossingEvent-detail
 971   (c-lambda (XEvent*)       ;; XEvent box
 972             int
 973             "___result = ___arg1->xcrossing.detail;"))
 974
 975 (define XCrossingEvent-same-screen
 976   (c-lambda (XEvent*)       ;; XEvent box
 977             bool
 978             "___result = ___arg1->xcrossing.same_screen;"))
 979
 980 (define XCrossingEvent-focus
 981   (c-lambda (XEvent*)       ;; XEvent box
 982             bool
 983             "___result = ___arg1->xcrossing.focus;"))
 984
 985 (define XCrossingEvent-state
 986   (c-lambda (XEvent*)       ;; XEvent box
 987             unsigned-int
 988             "___result = ___arg1->xcrossing.state;"))
 989
 990 (define XConfigureEvent-x
 991   (c-lambda (XEvent*)       ;; XEvent box
 992             int
 993             "___result = ___arg1->xconfigure.x;"))
 994
 995 (define XConfigureEvent-y
 996   (c-lambda (XEvent*)       ;; XEvent box
 997             int
 998             "___result = ___arg1->xconfigure.y;"))
 999
1000 (define XConfigureEvent-width
1001   (c-lambda (XEvent*)       ;; XEvent box
1002             int
1003             "___result = ___arg1->xconfigure.width;"))
1004
1005 (define XConfigureEvent-height
1006   (c-lambda (XEvent*)       ;; XEvent box
1007             int
1008             "___result = ___arg1->xconfigure.height;"))
1009
1010 (define XConfigureEvent-border-width
1011   (c-lambda (XEvent*)       ;; XEvent box
1012             int
1013             "___result = ___arg1->xconfigure.border_width;"))
1014
1015 (define XResizeRequestEvent-width
1016   (c-lambda (XEvent*)       ;; XEvent box
1017             int
1018             "___result = ___arg1->xresizerequest.width;"))
1019
1020 (define XResizeRequestEvent-height
1021   (c-lambda (XEvent*)       ;; XEvent box
1022             int
1023             "___result = ___arg1->xresizerequest.height;"))
1024
1025 (define XLookupString
1026   (c-lambda (XEvent*)      ;; event_struct (XKeyEvent)
1027             KeySym
1028 #<<end-of-c-lambda
1029 char buf[10];
1030 KeySym ks;
1031 XComposeStatus cs;
1032 int n = XLookupString (___CAST(XKeyEvent*,___arg1),
1033                        buf,
1034                        sizeof (buf),
1035                        &ks,
1036                        &cs);
1037 ___result = ks;
1038 end-of-c-lambda
1039 ))
1040
1041 (define (convert-XEvent ev)
1042   (and ev
1043        (let ((type (XAnyEvent-type ev)))
1044
1045          (cond ((or (##fixnum.= type KeyPress)
1046                     (##fixnum.= type KeyRelease))
1047                 (##list
1048                  (if (##fixnum.= type KeyPress)
1049                      'XKeyPressedEvent
1050                      'XKeyReleasedEvent)
1051                  type
1052                  (XAnyEvent-serial ev)
1053                  (XAnyEvent-send-event ev)
1054                  (XAnyEvent-display ev)
1055                  (XAnyEvent-window ev)
1056                  (XKeyEvent-root ev)
1057                  (XKeyEvent-subwindow ev)
1058                  (XKeyEvent-time ev)
1059                  (XKeyEvent-x ev)
1060                  (XKeyEvent-y ev)
1061                  (XKeyEvent-x-root ev)
1062                  (XKeyEvent-y-root ev)
1063                  (XKeyEvent-state ev)
1064                  (XKeyEvent-keycode ev)
1065                  (XKeyEvent-same-screen ev)
1066                  (XLookupString ev)))
1067
1068                ((or (##fixnum.= type ButtonPress)
1069                     (##fixnum.= type ButtonRelease))
1070                 (##list
1071                  (if (##fixnum.= type ButtonPress)
1072                      'XButtonPressedEvent
1073                      'XButtonReleasedEvent)
1074                  type
1075                  (XAnyEvent-serial ev)
1076                  (XAnyEvent-send-event ev)
1077                  (XAnyEvent-display ev)
1078                  (XAnyEvent-window ev)
1079                  (XButtonEvent-root ev)
1080                  (XButtonEvent-subwindow ev)
1081                  (XButtonEvent-time ev)
1082                  (XButtonEvent-x ev)
1083                  (XButtonEvent-y ev)
1084                  (XButtonEvent-x-root ev)
1085                  (XButtonEvent-y-root ev)
1086                  (XButtonEvent-state ev)
1087                  (XButtonEvent-button ev)
1088                  (XButtonEvent-same-screen ev)))
1089
1090                ((##fixnum.= type MotionNotify)
1091                 (##list
1092                  'XPointerMovedEvent
1093                  type
1094                  (XAnyEvent-serial ev)
1095                  (XAnyEvent-send-event ev)
1096                  (XAnyEvent-display ev)
1097                  (XAnyEvent-window ev)
1098                  (XMotionEvent-root ev)
1099                  (XMotionEvent-subwindow ev)
1100                  (XMotionEvent-time ev)
1101                  (XMotionEvent-x ev)
1102                  (XMotionEvent-y ev)
1103                  (XMotionEvent-x-root ev)
1104                  (XMotionEvent-y-root ev)
1105                  (XMotionEvent-state ev)
1106                  (XMotionEvent-is-hint ev)
1107                  (XMotionEvent-same-screen ev)))
1108
1109                ((or (##fixnum.= type EnterNotify)
1110                     (##fixnum.= type LeaveNotify))
1111                 (##list
1112                  (if (##fixnum.= type EnterNotify)
1113                      'XEnterWindowEvent
1114                      'XLeaveWindowEvent)
1115                  type
1116                  (XAnyEvent-serial ev)
1117                  (XAnyEvent-send-event ev)
1118                  (XAnyEvent-display ev)
1119                  (XAnyEvent-window ev)
1120                  (XCrossingEvent-root ev)
1121                  (XCrossingEvent-subwindow ev)
1122                  (XCrossingEvent-time ev)
1123                  (XCrossingEvent-x ev)
1124                  (XCrossingEvent-y ev)
1125                  (XCrossingEvent-x-root ev)
1126                  (XCrossingEvent-y-root ev)
1127                  (XCrossingEvent-mode ev)
1128                  (XCrossingEvent-detail ev)
1129                  (XCrossingEvent-same-screen ev)
1130                  (XCrossingEvent-focus ev)
1131                  (XCrossingEvent-state ev)))
1132
1133                ((##fixnum.= type ConfigureNotify)
1134                 (##list
1135                  'XConfigureEvent
1136                  type
1137                  (XAnyEvent-serial ev)
1138                  (XAnyEvent-send-event ev)
1139                  (XAnyEvent-display ev)
1140                  (XAnyEvent-window ev)
1141                  (XConfigureEvent-x ev)
1142                  (XConfigureEvent-y ev)
1143                  (XConfigureEvent-width ev)
1144                  (XConfigureEvent-height ev)
1145                  (XConfigureEvent-border-width ev)))
1146
1147                ((##fixnum.= type ResizeRequest)
1148                 (##list
1149                  'XResizeRequestEvent
1150                  type
1151                  (XAnyEvent-serial ev)
1152                  (XAnyEvent-send-event ev)
1153                  (XAnyEvent-display ev)
1154                  (XAnyEvent-window ev)
1155                  (XResizeRequestEvent-width ev)
1156                  (XResizeRequestEvent-height ev)))
1157
1158                (else
1159                 #f)))))
1160
1161 ;;;============================================================================