211 lines
6.7 KiB
Scheme
211 lines
6.7 KiB
Scheme
;; Copyright (c) 2001-2003 by Norbert Freudemann, David Frese
|
|
|
|
;; TODO: pixmap-formats (XListPixmapFormats)
|
|
(define-record-type display :display
|
|
(make-display cpointer connection-number protocol-version protocol-revision
|
|
server-vendor image-byte-order bitmap-unit bitmap-pad
|
|
bitmap-bit-order vendor-release queue-length name
|
|
default-screen screens after-function wakeup)
|
|
display?
|
|
(cpointer display:cpointer)
|
|
(connection-number display:connection-number)
|
|
(protocol-version display:protocol-version)
|
|
(protocol-revision display:protocol-revision)
|
|
(server-vendor display:server-vendor)
|
|
(image-byte-order display:image-byte-order)
|
|
(bitmap-unit display:bitmap-unit)
|
|
(bitmap-pad display:bitmap-pad)
|
|
(bitmap-bit-order display:bitmap-bit-order)
|
|
(vendor-release display:vendor-release)
|
|
(queue-length display:queue-length)
|
|
(name display:name)
|
|
(default-screen display:default-screen)
|
|
(screens display:screens)
|
|
(after-function display:after-function set-display:after-function!)
|
|
(wakeup display:wakeup set-display:wakeup!))
|
|
|
|
(define-exported-binding "scx-display" :display)
|
|
|
|
;(define (wakeup-display dpy)
|
|
; (placeholder-set! dpy #t))
|
|
|
|
;(define (sleep-display dpy)
|
|
; (let ((ph (make-placeholder)))
|
|
; (set-display:wakeup! dpy ph)
|
|
; (placeholder-value ph)))
|
|
|
|
(define (initialize-display dpy)
|
|
; (set-display:wakeup! dpy (make-placeholder))
|
|
; ;; spawn a thread that weaks up a waiting wait-event call if the
|
|
; ;; inport has data available
|
|
; (spawn (lambda ()
|
|
; (let loop ()
|
|
; (block-on-message-inport dpy)
|
|
; (wakeup-display dpy)
|
|
; (loop))))
|
|
;; the after-function may also send a wakup
|
|
#t)
|
|
|
|
(define-exported-binding "scx-initialize-display" initialize-display)
|
|
|
|
(define (display-message-inport display)
|
|
(fdes->inport (display:connection-number display)))
|
|
|
|
(define (block-on-message-inport dpy . maybe-timeout)
|
|
(let ((port (display-message-inport dpy)))
|
|
(call-with-values
|
|
(lambda () (apply select (vector port) (vector) (vector) maybe-timeout))
|
|
(lambda (ready-read ready-write ex)
|
|
(member port (vector->list ready-read))))))
|
|
|
|
(define-enumerated-type byte-order :byte-order
|
|
byte-order? byte-orders byte-order-name byte-order-index
|
|
(lsb-first msb-first))
|
|
|
|
(define-exported-binding "scx-byte-order" :byte-order)
|
|
(define-exported-binding "scx-byte-orders" byte-orders)
|
|
|
|
(define-enumerated-type bit-order :bit-order
|
|
bit-order? bit-orders bit-order-name bit-order-index
|
|
(lsb-first msb-first))
|
|
|
|
(define-exported-binding "scx-bit-order" :bit-order)
|
|
(define-exported-binding "scx-bit-orders" bit-orders)
|
|
|
|
(define-record-type screen-format :screen-format ;; aka pixmap-format
|
|
(make-screen-format depth bits-per-pixel scanline-pad)
|
|
screen-format?
|
|
(depth screen-format:depth)
|
|
(bits-per-pixel screen-format:bits-per-pixel)
|
|
(scanline-pad screen-format:scanline-pad))
|
|
|
|
(define-exported-binding "scx-screen-format" :screen-format)
|
|
|
|
(define-record-type screen :screen
|
|
(make-screen cpointer display root-window width height width-mm
|
|
height-mm number root-depth default-visual default-gc
|
|
default-colormap white-pixel black-pixel max-maps min-maps
|
|
does-backing-store does-save-unders? event-mask)
|
|
;; maybe add depths ?? (TODO)
|
|
;; does event-mask change ?? (TODO)
|
|
screen?
|
|
(cpointer screen:cpointer)
|
|
(display screen:display)
|
|
(root-window screen:root-window)
|
|
(width screen:width)
|
|
(height screen:height)
|
|
(width-mm screen:width-mm)
|
|
(height-mm screen:height-mm)
|
|
(number screen:number)
|
|
(root-depth screen:root-depth)
|
|
(default-visual screen:default-visual)
|
|
(default-gc screen:default-gc)
|
|
(default-colormap screen:default-colormap)
|
|
(white-pixel screen:white-pixel)
|
|
(black-pixel screen:black-pixel)
|
|
(max-maps screen:max-maps)
|
|
(min-maps screen:min-maps)
|
|
(does-backing-store screen:does-backing-store)
|
|
(does-save-unders? screen:does-save-unders?)
|
|
(event-mask screen:event-mask))
|
|
|
|
(define-exported-binding "scx-screen" :screen)
|
|
|
|
;(define (screen:cells screen)
|
|
; (visual:map-entries (screen:default-visual screen)))
|
|
|
|
;; *** connect or disconnect to X server *****************************
|
|
|
|
(import-lambda-definition %open-display (display-name)
|
|
"scx_Open_Display")
|
|
|
|
;; returns a display or #f
|
|
(define (open-display . args)
|
|
(let ((display-name (if (null? args)
|
|
""
|
|
(if (null? (cdr args))
|
|
(cadr args)
|
|
(error "invalid arguments" (cdr args))))));; TODO
|
|
(%open-display display-name)))
|
|
|
|
(import-lambda-definition close-display (display)
|
|
"scx_Close_Display")
|
|
|
|
(define none 0)
|
|
(define parent-relative 1)
|
|
(define copy-from-parent 0)
|
|
(define pointer-window 0)
|
|
(define input-focus 1)
|
|
(define pointer-root 1)
|
|
(define any-property-type 0)
|
|
(define any-key 0)
|
|
(define all-temporary 0)
|
|
(define current-time 0)
|
|
(define no-symbol 0)
|
|
(define all-planes (- (arithmetic-shift 1 32) 1))
|
|
|
|
(import-lambda-definition display:last-request-read (display)
|
|
"scx_Display_Last_Request_Read")
|
|
|
|
;; *** convenience functions *****************************************
|
|
|
|
(define (default-root-window display)
|
|
(screen:root-window (display:default-screen display)))
|
|
|
|
(define (black-pixel display)
|
|
(screen:black-pixel (display:default-screen display)))
|
|
|
|
(define (white-pixel display)
|
|
(screen:white-pixel (display:default-screen display)))
|
|
|
|
(import-lambda-definition next-request (display)
|
|
"scx_Next_Request")
|
|
|
|
;; *** enable or disable synchronization *****************************
|
|
|
|
(define (synchronize dpy on?)
|
|
(if on?
|
|
(set-after-function! dpy
|
|
(lambda (dpy)
|
|
(display-sync dpy #f)))
|
|
(set-after-function! dpy #f)))
|
|
|
|
;; returns the previous after-function. An after-function is called
|
|
;; with the display object.
|
|
|
|
(define (general-after-function display)
|
|
(if (display:after-function display)
|
|
((display:after-function display) display)
|
|
;; else the default behaviour ;; TODO: check if this is the real one
|
|
(display-flush display))
|
|
)
|
|
;; if events are in the queue now, then wakeup a wait-event call
|
|
;;(if (> (events-queued display (queued-mode already)) 0)
|
|
;; (wakeup-display display)))
|
|
|
|
(define-exported-binding "scx-general-after-function" general-after-function)
|
|
|
|
(define (set-after-function! display fun)
|
|
(let ((prev (display:after-function display)))
|
|
(set-display:after-function! display fun)
|
|
prev))
|
|
|
|
;; *** handle output buffer or event queue ***************************
|
|
|
|
(import-lambda-definition display-flush (display)
|
|
"scx_Display_Flush")
|
|
|
|
(import-lambda-definition display-sync (display discard?)
|
|
"scx_Display_Sync")
|
|
|
|
;; display-no-op sends a NoOperation protocol request to the X server, thereby
|
|
;; exercising the connection. See XNoOp.
|
|
|
|
(import-lambda-definition display-no-op (display)
|
|
"scx_No_Op")
|
|
|
|
;; *** select input events *******************************************
|
|
|
|
(import-lambda-definition display-select-input (display window event-mask)
|
|
"scx_Display_Select_Input")
|