scx/scheme/xlib/display.scm

;; 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))))