Untested implementation of the display stuff.
This commit is contained in:
frese
parent
e87ee02ee9
commit
d6a249c4fe
|
|
@ -0,0 +1,326 @@
|
|||
;; Author: David Frese
|
||||
|
||||
(define-record-type display :display
|
||||
(really-make-display after-function Xdisplay)
|
||||
display?
|
||||
(after-function display-after-function display-set-after-function!)
|
||||
(Xdisplay display-Xdisplay display-set-Xdisplay!))
|
||||
|
||||
;; for compatibility with elk:
|
||||
(define set-after-function! display-set-after-function!)
|
||||
(define after-function display-after-function)
|
||||
|
||||
(define (make-display Xdisplay)
|
||||
(let ((maybe-display (display-list-find Xdisplay)))
|
||||
(if maybe-display
|
||||
maybe-display
|
||||
(let ((display (really-make-display #f Xdisplay)))
|
||||
(add-finalizer! display finalize-display)
|
||||
(display-list-set! Xdisplay display)
|
||||
display))))
|
||||
|
||||
(define-exported-binding "display-record-type" :display)
|
||||
|
||||
(define (open-display . args)
|
||||
(let ((display-name (if (null? args)
|
||||
#f
|
||||
(let ((dpy-name (car args)))
|
||||
(cond
|
||||
((symbol? dpy-name) (symbol->string dpy-name))
|
||||
(else dpy-name))))))
|
||||
(let ((Xdisplay (%open-display display-name)))
|
||||
(if (= Xdisplay 0)
|
||||
(error "cannot open display" display-name)
|
||||
(make-display Xdisplay)))))
|
||||
|
||||
(import-lambda-definition %open-display (name) "Open_Display")
|
||||
|
||||
;; finalize-display is called, when the garbage collector removes the last
|
||||
;; reference to display from the heap. Then we can savely close the display
|
||||
;; and remove the weak-pointer from out list.
|
||||
|
||||
(define (finalize-display display)
|
||||
(let ((Xdisplay (display-Xdisplay display)))
|
||||
(close-display display)
|
||||
(display-list-delete! Xdisplay)))
|
||||
|
||||
;; close-display closes the corresponding Xlib-display struct, by calling a
|
||||
;; c-function and marks the scheme-record to be invalid (with the
|
||||
;; 'already-closed symbol). Calling close-display more than once has no
|
||||
;; effects.
|
||||
|
||||
(define (close-display display)
|
||||
(let ((Xdisplay (display-Xdisplay display)))
|
||||
(if (integer? Xdisplay)
|
||||
(begin
|
||||
((display-after-function display) display)
|
||||
(%close-display Xdisplay)
|
||||
(display-set-Xdisplay display 'already-closed)))))
|
||||
|
||||
(import-lambda-definition %close-display (Xdisplay) "Close_Display")
|
||||
|
||||
;; All display records need to be saved in a weak-list, to have only one record
|
||||
;; for the same Xlib display-structure in the heap.
|
||||
|
||||
(define *weak-display-list* (make-integer-table))
|
||||
|
||||
(define (display-list-find Xdisplay)
|
||||
(let ((r (table-ref *weak-display-list* Xdisplay)))
|
||||
(if r
|
||||
(weak-pointer-ref r)
|
||||
r)))
|
||||
|
||||
(define (display-list-set! Xdisplay display)
|
||||
(let ((p (make-weak-pointer display)))
|
||||
(table-set! *weak-display-list* Xdisplay p)))
|
||||
|
||||
(define (display-list-delete! Xdisplay)
|
||||
(display-list-set! Xdisplay #f))
|
||||
|
||||
;; ...
|
||||
|
||||
(define (display-default-root-window display)
|
||||
(let* ((Xdisplay (display-Xdisplay display))
|
||||
(Xwindow (%default-root-window Xdisplay)))
|
||||
(make-window 0 Xdisplay Xwindow)))
|
||||
|
||||
(define display-root-window display-default-root-window)
|
||||
|
||||
(import-lambda-definition %default-root-window (Xdisplay)
|
||||
"Display_Default_Root_Window")
|
||||
|
||||
;; ...
|
||||
|
||||
(define (display-default-colormap display)
|
||||
(let* ((Xdisplay (display-Xdisplay display))
|
||||
(Xcolormap (%default-colormap Xdisplay)))
|
||||
(make-colormap 0 Xdisplay Xcolormap)))
|
||||
|
||||
(define display-colormap display-default-colormap)
|
||||
|
||||
(import-lambda-definition %default-colormap (Xdisplay)
|
||||
"Display_Default_Colormap")
|
||||
|
||||
;; ...
|
||||
|
||||
(define (display-default-gcontext display)
|
||||
(let* ((Xdisplay (display-Xdisplay display))
|
||||
(Xgcontext (%default-gcontext Xdisplay)))
|
||||
(make-gcontext 0 Xdisplay Xgcontext)))
|
||||
|
||||
(import-lambda-definition %default-gcontext (Xdisplay)
|
||||
"Display_Default_Gcontext")
|
||||
|
||||
;; ...
|
||||
|
||||
(define (display-default-depth display)
|
||||
(let ((Xdisplay (display-Xdisplay display)))
|
||||
(%default-depth Xdisplay)))
|
||||
|
||||
(import-lambda-defintion %default-depth (Xdisplay)
|
||||
"Display_Default_Depth")
|
||||
|
||||
;; ...
|
||||
|
||||
(define (display-default-screen-number display)
|
||||
(let ((Xdisplay (display-Xdisplay display)))
|
||||
(%default-screen-number Xdisplay)))
|
||||
|
||||
(import-lambda-definition %default-screen-number (Xdisplay)
|
||||
"Display_Default_Screen_Number")
|
||||
|
||||
;; ...
|
||||
|
||||
(define (check-screen-number display screen-number)
|
||||
(if (or (< screen-number 0)
|
||||
(>= screen-number (display-screen-count display)))
|
||||
(error "invalid screen number" screen-number)))
|
||||
|
||||
(define (display-cells display screen-number)
|
||||
(check-screen-number display screen-number)
|
||||
(%display-cells (display-Xdisplay display) screen-number))
|
||||
|
||||
(import-lambda-definition %display-cells (Xdisplay screen-number)
|
||||
"Display_Cells")
|
||||
|
||||
;; ...
|
||||
|
||||
(define (display-planes display screen-number)
|
||||
(check-screen-number display screen-number)
|
||||
(%display-planes (display-Xdisplay display) screen-number))
|
||||
|
||||
(import-lambda-definition %display-planes (Xdisplay screen-number)
|
||||
"Display_Planes")
|
||||
|
||||
;; ...
|
||||
|
||||
(define (display-string display)
|
||||
(%display-string (display-Xdisplay display)))
|
||||
|
||||
(import-lambda-definition %display-string (Xdisplay)
|
||||
"Display_String")
|
||||
|
||||
;; Display-Vendor returns a pair, whose car is the vendor identification and
|
||||
;; whose cdr is the release number
|
||||
|
||||
(define (display-vendor display)
|
||||
(%display-vendor (display-Xdisplay display)))
|
||||
|
||||
(import-lambda-defintion %display-vendor (Xdisplay)
|
||||
"Display_Vendor")
|
||||
|
||||
;; Display-protocol-version return a pair of major and minor version numbers of
|
||||
;; the X protocol.
|
||||
|
||||
(define (display-protocol-version display)
|
||||
(%display-protocol-version (display-Xdisplay display)))
|
||||
|
||||
(import-lambda-definition %display-protocol-version (Xdisplay)
|
||||
"Display_Protocol_Version")
|
||||
|
||||
;; ...
|
||||
|
||||
(define (display-screen-count display)
|
||||
(%display-screen-count (display-Xdisplay display)))
|
||||
|
||||
(import-lambda-definition %display-screen-count (Xdisplay)
|
||||
"Display_Screen_Count")
|
||||
|
||||
;; display-image-byte-order returns one of the symbols 'lsb-first and
|
||||
;; 'msb-first.
|
||||
|
||||
(define (display-image-byte-order display)
|
||||
(%display-image-byte-order (display-Xdisplay display)))
|
||||
|
||||
(import-lambda-definition %display-image-byte-order (Xdisplay)
|
||||
"Display_Image_Byte_Order")
|
||||
|
||||
;; ...
|
||||
|
||||
(define (display-bitmap-unit display)
|
||||
(%display-bitmap-unit (display-Xdisplay display)))
|
||||
|
||||
(import-lambda-definition %display-bitmap-unit (Xdisplay)
|
||||
"Display_Bitmap_Unit")
|
||||
|
||||
;; ...
|
||||
|
||||
(define (display-bitmap-bit-order display)
|
||||
(%display-bitmap-bit-order (display-Xdisplay display)))
|
||||
|
||||
(import-lambda-definition %display-bitmap-bit-order (Xdisplay)
|
||||
"Display_Bitmap_Bit_Order")
|
||||
|
||||
;; ...
|
||||
|
||||
|
||||
(define (display-bitmap-pad display)
|
||||
(%display-bitmap-pad (display-Xdisplay display)))
|
||||
|
||||
(import-lambda-definition %display-bitmap-pad (Xdisplay)
|
||||
"Display_Bitmap_Pad")
|
||||
|
||||
;; ...
|
||||
|
||||
(define (display-width display)
|
||||
(%display-width (display-Xdisplay display)))
|
||||
|
||||
(import-lambda-definition %display-width (Xdisplay)
|
||||
"Display_Width")
|
||||
|
||||
;; ...
|
||||
|
||||
(define (display-height display)
|
||||
(%display-height (display-Xdisplay display)))
|
||||
|
||||
(import-lambda-definition %display-height (Xdisplay)
|
||||
"Display_Height")
|
||||
|
||||
;; ...
|
||||
|
||||
(define (display-width-mm display)
|
||||
(%display-width-mm (display-Xdisplay display)))
|
||||
|
||||
(import-lambda-definition %display-width-mm (Xdisplay)
|
||||
"Display_Width_Mm")
|
||||
|
||||
;; ...
|
||||
|
||||
(define (display-width-mm display)
|
||||
(%display-width-mm (display-Xdisplay display)))
|
||||
|
||||
(import-lambda-definition %display-width-mm (Xdisplay)
|
||||
"Display_Width_Mm")
|
||||
|
||||
;; ...
|
||||
|
||||
(define (display-height-mm display)
|
||||
(%display-height-mm (display-Xdisplay display)))
|
||||
|
||||
(import-lambda-definition %display-height-mm (Xdisplay)
|
||||
"Display_Height_Mm")
|
||||
|
||||
;; ...
|
||||
|
||||
(define (display-motion-buffer-size display)
|
||||
(%display-motion-buffer-size (display-Xdisplay display)))
|
||||
|
||||
(import-lambda-definition %display-motion-buffer-size (Xdisplay)
|
||||
"Display_Motion_Buffer_Size")
|
||||
|
||||
;; ... the result is unspecific
|
||||
|
||||
(define (display-flush-output display)
|
||||
(%display-flush-output (display-Xdisplay display)))
|
||||
|
||||
(import-lambda-definiton %display-flush-output (Xdisplay)
|
||||
"Display_Flush_Output")
|
||||
|
||||
;; ... the result is unspecific
|
||||
|
||||
(define (display-wait-output display discard-events?)
|
||||
(%display-wait-output (display-Xdisplay display)
|
||||
discard-events?))
|
||||
|
||||
(import-lambda-definition %display-wait-ouput (Xdisplay discard)
|
||||
"Display_Wait_Output")
|
||||
|
||||
;; ... the result is unspecific
|
||||
|
||||
(define (display-no-op display)
|
||||
(%no-op (display-Xdisplay display)))
|
||||
|
||||
(import-lambda-definition %no-op (Xdisplay)
|
||||
"No_Op")
|
||||
|
||||
(define no-op display-no-op)
|
||||
|
||||
;; ... returns a vector of integers
|
||||
|
||||
(define (display-list-depths display screen-number)
|
||||
(%display-list-depths (display-Xdisplay display)
|
||||
(check-screen-number screen-number)))
|
||||
|
||||
(import-lambda-definition %display-list-depths (Xdisplay scr)
|
||||
"List_Depths")
|
||||
|
||||
(define list-depths display-list-depths)
|
||||
|
||||
;; ... returns a vector of lists with 3 integers (depth, bits per pixel,
|
||||
;; scanline pad)
|
||||
|
||||
(define (display-list-pixmap-formats display)
|
||||
(%display-list-pixmap-formats (display-Xdisplay display)))
|
||||
|
||||
(import-lambda-definition %display-list-pixmap-formats (Xdisplay)
|
||||
"List_Pixmap_Formats")
|
||||
|
||||
;; synchronize just sets the after-function of the display to
|
||||
;; display-wait-output (with #f for discard-events?).
|
||||
|
||||
(define (synchronize display)
|
||||
(display-set-after-function!
|
||||
display
|
||||
(lambda (display)
|
||||
(display-wait-output display #f))))
|
||||
|
||||
|
|
@ -0,0 +1,55 @@
|
|||
;;; The display structure
|
||||
|
||||
(define-interface xlib-display-interface
|
||||
(export display?
|
||||
open-display
|
||||
close-display
|
||||
display-after-function
|
||||
after-function ;; compatibility with Elk, same as above
|
||||
display-set-after-function!
|
||||
set-after-function! ;; compatibility with Elk, same as above
|
||||
display-default-root-window
|
||||
display-root-window ;; same as above
|
||||
display-default-colormap
|
||||
display-colormap ;; same as above
|
||||
display-default-gcontext
|
||||
display-default-depth
|
||||
display-default-screen-number
|
||||
display-cells
|
||||
display-planes
|
||||
display-string
|
||||
display-vendor
|
||||
display-protocol-version
|
||||
display-screen-count
|
||||
display-image-byte-order
|
||||
display-bitmap-unit
|
||||
display-bitmap-bit-order
|
||||
display-bitmap-pad
|
||||
display-width
|
||||
display-height
|
||||
display-width-mm
|
||||
display-height-mm
|
||||
display-motion-buffer-size
|
||||
display-flush-output
|
||||
display-wait-output
|
||||
display-no-op
|
||||
no-op ;; compatibility with Elk, same as above
|
||||
display-list-depths
|
||||
list-depths ;; compatibility with Elk, same as above
|
||||
display-list-pixmap-formats
|
||||
list-pixmap-formats ;; compatibility with Elk, same as above
|
||||
synchronize
|
||||
|
||||
))
|
||||
|
||||
(define-structure xlib-display xlib-display-interface
|
||||
(open scsh
|
||||
scheme
|
||||
define-record-types
|
||||
weak
|
||||
general-tables
|
||||
; xlib-window
|
||||
primitives)
|
||||
(files "display.scm"))
|
||||
|
||||
;;; ...
|
||||
Loading…
Reference in New Issue