scsh-conservatory
/
scx
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

- fixed a bug with the default-screen 

- fixed sync-event queue problem
This commit is contained in:
frese 2003-03-13 15:17:36 +00:00
parent 9748014efe
commit 968e69403f
4 changed files with 16 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
scheme/examples/hello.scm
View File

@ -56,9 +56,11 @@
(draw-text dpy win gc 20 40 (draw-text dpy win gc 20 40
(make-text-items text (change-font font2) (make-text-items text (change-font font2)
(with-delta 20 text)))) (with-delta 20 text))))
((motion-event? e) #t)
(else #f))) (else #f)))
(loop)))))) (loop))))))
(call-with-event-channel dpy win (event-mask exposure button-press) (call-with-event-channel dpy win (event-mask exposure button-press
pointer-motion)
handler) handler)
(close-display dpy)))) (close-display dpy))))

9
scheme/xlib/display.scm
View File

@ -120,16 +120,13 @@
;; *** convenience functions ***************************************** ;; *** convenience functions *****************************************
(define (default-root-window display) (define (default-root-window display)
(screen:root-window (list-ref (display:screens display) (screen:root-window (display:default-screen display)))
(display:default-screen display))))
(define (black-pixel display) (define (black-pixel display)
(screen:black-pixel (list-ref (display:screens display) (screen:black-pixel (display:default-screen display)))
(display:default-screen display))))
(define (white-pixel display) (define (white-pixel display)
(screen:white-pixel (list-ref (display:screens display) (screen:white-pixel (display:default-screen display)))
(display:default-screen display))))
(import-lambda-definition next-request (display) (import-lambda-definition next-request (display)
"scx_Next_Request") "scx_Next_Request")

11
scheme/xlib/sync-event.scm
View File

@ -100,19 +100,22 @@
(define (call-with-event-channel display window event-mask fun) (define (call-with-event-channel display window event-mask fun)
(let ((r (make-request display window event-mask)) (let ((r (make-request display window event-mask))
(channel (make-channel))) (channel (make-channel)))
(spawn-event-filter (most-recent-sync-x-event) (spawn-event-filter channel display window event-mask)
channel display window event-mask) ;; we send the first sync-event to the thread to really have the
;; most recent one, without keeping it in an environment.
(send channel (most-recent-sync-x-event))
(dynamic-wind (dynamic-wind
(lambda () (add-request! r)) (lambda () (add-request! r))
(lambda () (fun channel)) (lambda () (fun channel))
(lambda () (remove-request! r))))) (lambda () (remove-request! r)))))
(define (spawn-event-filter se out-channel display window event-mask) (define (spawn-event-filter out-channel display window event-mask)
(let ((pred (lambda (e) (let ((pred (lambda (e)
(and (eq? (any-event-display e) display) (and (eq? (any-event-display e) display)
(matches-event-mask? window event-mask e))))) (matches-event-mask? window event-mask e)))))
(spawn (lambda () (spawn (lambda ()
(let loop ((se se)) ;; the first sync-event is send to us through the channel
(let loop ((se (receive out-channel)))
(let ((nse (next-sync-x-event se pred))) (let ((nse (next-sync-x-event se pred)))
(send out-channel (sync-x-event-event nse)) (send out-channel (sync-x-event-event nse))
(loop nse))))))) (loop nse)))))))

6
scheme/xlib/xlib-packages.scm
View File

@ -14,7 +14,8 @@
(define-structures ((xlib xlib-interface) (define-structures ((xlib xlib-interface)
(xlib-internal xlib-internal-interface)) (xlib-internal xlib-internal-interface))
(open scsh-level-0 (open rendezvous-channels
scsh-level-0
scheme scheme
list-lib list-lib
srfi-13 ;; strings srfi-13 ;; strings
@ -31,8 +32,7 @@
channel-i/o channel-i/o
interrupts interrupts
ascii ascii
conditions conditions)
rendezvous-channels)
(files display (files display
visual visual
colormap colormap