Has moved to main scheme-dir.
This commit is contained in:
frese
parent
6179ac994a
commit
a55d007131
|
|
@ -1,73 +0,0 @@
|
||||||
;; the color-datatype ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
|
|
||||||
(define-record-type color :color
|
|
||||||
(really-make-color tag Xcolor)
|
|
||||||
color?
|
|
||||||
(tag color-tag color-set-tag!)
|
|
||||||
(Xcolor color-Xcolor color-set-Xcolor!))
|
|
||||||
|
|
||||||
(define (internal-make-color Xcolor)
|
|
||||||
(let ((maybe-color (color-list-find Xcolor)))
|
|
||||||
(if maybe-color
|
|
||||||
maybe-color
|
|
||||||
(let ((color (really-make-color #f Xcolor)))
|
|
||||||
(add-finalizer! color finalize-color)
|
|
||||||
(color-list-set! Xcolor color)
|
|
||||||
color))))
|
|
||||||
|
|
||||||
;; r, g, b should be integers from 0 to 65535
|
|
||||||
(define (create-color r g b)
|
|
||||||
(let ((maybe-color (color-list-find* r g b)))
|
|
||||||
(if maybe-color
|
|
||||||
maybe-color
|
|
||||||
(internal-make-color (%create-color r g b)))))
|
|
||||||
|
|
||||||
(import-lambda-definition %create-color (r g b)
|
|
||||||
"Create_Color")
|
|
||||||
|
|
||||||
(define-exported-binding "color-record-type" :color)
|
|
||||||
|
|
||||||
;; returns a list of r,g,b as integers
|
|
||||||
(define (extract-rgb-values color)
|
|
||||||
(%extract-rgb-values (color-Xcolor color)))
|
|
||||||
|
|
||||||
(import-lambda-definition %extract-rgb-values (XColor)
|
|
||||||
"Extract_RGB_Values")
|
|
||||||
|
|
||||||
;; finalize-color is called, when the garbage collector removes the last
|
|
||||||
;; reference to the color from the heap. Then we can savely close the color
|
|
||||||
;; and remove the weak-pointer from our list.
|
|
||||||
|
|
||||||
(define (finalize-color color)
|
|
||||||
(let ((Xcolor (color-Xcolor color)))
|
|
||||||
;;(destroy-color color)
|
|
||||||
(color-set-Xcolor! color 'already-destroyed)
|
|
||||||
(color-list-delete! Xcolor)))
|
|
||||||
|
|
||||||
;; All color records need to be saved in a weak-list, to have only one record
|
|
||||||
;; for the same r,g,b value in the heap.
|
|
||||||
|
|
||||||
(define *weak-color-list* (make-integer-table))
|
|
||||||
|
|
||||||
(define (color-list-find Xcolor)
|
|
||||||
(let ((r (table-ref *weak-color-list* Xcolor)))
|
|
||||||
(if r
|
|
||||||
(weak-pointer-ref r)
|
|
||||||
r)))
|
|
||||||
|
|
||||||
(define (color-list-find* r g b) ;; r,g,b as integers
|
|
||||||
(call/cc (lambda (return)
|
|
||||||
(table-walk (lambda (key value)
|
|
||||||
(let ((color (weak-pointer-ref value)))
|
|
||||||
(if (equal? (list r g b)
|
|
||||||
(extract-rgb-values color))
|
|
||||||
(return key))))
|
|
||||||
*weak-color-list*)
|
|
||||||
#f)))
|
|
||||||
|
|
||||||
(define (color-list-set! Xcolor color)
|
|
||||||
(let ((p (make-weak-pointer color)))
|
|
||||||
(table-set! *weak-color-list* Xcolor p)))
|
|
||||||
|
|
||||||
(define (color-list-delete! Xcolor)
|
|
||||||
(table-set! *weak-color-list* Xcolor #f))
|
|
||||||
|
|
@ -1,65 +0,0 @@
|
||||||
;; the colormap-datatype ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
|
|
||||||
(define-record-type colormap :colormap
|
|
||||||
(really-make-colormap tag Xcolormap display)
|
|
||||||
colormap?
|
|
||||||
(tag colormap-tag colormap-set-tag!)
|
|
||||||
(Xcolormap real-colormap-Xcolormap colormap-set-Xcolormap!)
|
|
||||||
(display colormap-display colormap-set-display!))
|
|
||||||
|
|
||||||
(define (colormap-Xcolormap colormap)
|
|
||||||
(if (eq? colormap 'none)
|
|
||||||
none-resource
|
|
||||||
(real-colormap-Xcolormap colormap)))
|
|
||||||
|
|
||||||
(define (make-colormap Xcolormap display)
|
|
||||||
(if (none-resource? Xcolormap)
|
|
||||||
'none
|
|
||||||
(let ((maybe-colormap (colormap-list-find Xcolormap)))
|
|
||||||
(if maybe-colormap
|
|
||||||
maybe-colormap
|
|
||||||
(let ((colormap (really-make-colormap #f Xcolormap display)))
|
|
||||||
(add-finalizer! colormap finalize-colormap)
|
|
||||||
(colormap-list-set! Xcolormap colormap)
|
|
||||||
colormap)))))
|
|
||||||
|
|
||||||
(define-exported-binding "colormap-record-type" :colormap)
|
|
||||||
|
|
||||||
;; finalize-colormap is called, when the garbage collector removes the last
|
|
||||||
;; reference to the colormap from the heap. Then we can savely close the
|
|
||||||
;; colormap and remove the weak-pointer from our list.
|
|
||||||
|
|
||||||
(define (finalize-colormap colormap)
|
|
||||||
(let ((Xcolormap (colormap-Xcolormap colormap)))
|
|
||||||
(free-colormap colormap)
|
|
||||||
(colormap-list-delete! Xcolormap)))
|
|
||||||
|
|
||||||
(define (free-colormap colormap)
|
|
||||||
(let ((Xcolormap (colormap-Xcolormap)))
|
|
||||||
(if (integer? Xcolormap)
|
|
||||||
(begin
|
|
||||||
(%free-colormap Xcolormap
|
|
||||||
(display-Xdisplay (colormap-display colormap)))
|
|
||||||
(colormap-set-Xcolormap! colormap 'already-freed)))))
|
|
||||||
|
|
||||||
(import-lambda-definition %free-colormap (Xcolormap Xdisplay)
|
|
||||||
"Free_Colormap")
|
|
||||||
|
|
||||||
;; All colormap records need to be saved in a weak-list, to have only one record
|
|
||||||
;; for the same XLib colormap
|
|
||||||
|
|
||||||
(define *weak-colormap-list* (make-integer-table))
|
|
||||||
|
|
||||||
(define (colormap-list-find Xcolormap)
|
|
||||||
(let ((r (table-ref *weak-colormap-list* Xcolormap)))
|
|
||||||
(if r
|
|
||||||
(weak-pointer-ref r)
|
|
||||||
r)))
|
|
||||||
|
|
||||||
(define (colormap-list-set! Xcolormap colormap)
|
|
||||||
(let ((p (make-weak-pointer colormap)))
|
|
||||||
(table-set! *weak-colormap-list* Xcolormap p)))
|
|
||||||
|
|
||||||
(define (colormap-list-delete! Xcolormap)
|
|
||||||
(table-set! *weak-colormap-list* Xcolormap #f))
|
|
||||||
|
|
||||||
|
|
@ -1,61 +0,0 @@
|
||||||
;; the display-datatype ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
|
|
||||||
(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!))
|
|
||||||
|
|
||||||
(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)
|
|
||||||
|
|
||||||
;; finalize-display is called, when the garbage collector removes the last
|
|
||||||
;; reference to the display from the heap. Then we can savely close the display
|
|
||||||
;; and remove the weak-pointer from our 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)
|
|
||||||
(table-set! *weak-display-list* Xdisplay #f))
|
|
||||||
|
|
||||||
|
|
@ -1,43 +0,0 @@
|
||||||
(define-record-type pixel :pixel
|
|
||||||
(really-make-pixel tag Xpixel)
|
|
||||||
pixel?
|
|
||||||
(tag pixel-tag pixel-set-tag!)
|
|
||||||
(Xpixel pixel-Xpixel pixel-set-Xpixel!))
|
|
||||||
|
|
||||||
(define (make-pixel Xpixel)
|
|
||||||
(let ((maybe-pixel (pixel-list-find Xpixel)))
|
|
||||||
(if maybe-pixel
|
|
||||||
maybe-pixel
|
|
||||||
(let ((pixel (really-make-pixel #f Xpixel)))
|
|
||||||
(add-finalizer! pixel finalize-pixel)
|
|
||||||
(pixel-list-set! Xpixel pixel)
|
|
||||||
pixel))))
|
|
||||||
|
|
||||||
(define-exported-binding "pixel-record-type" :pixel)
|
|
||||||
|
|
||||||
;; finalize-pixel is called, when the garbage collector removes the last
|
|
||||||
;; reference to the pixel from the heap. Then we can savely close the
|
|
||||||
;; pixel and remove the weak-pointer from our list.
|
|
||||||
|
|
||||||
(define (finalize-pixel pixel)
|
|
||||||
(let ((Xpixel (pixel-Xpixel pixel)))
|
|
||||||
(pixel-set-Xpixel! pixel 'already-destroyed)
|
|
||||||
(pixel-list-delete! Xpixel)))
|
|
||||||
|
|
||||||
;; All pixel records need to be saved in a weak-list, to have only one record
|
|
||||||
;; for the same XLib pixel
|
|
||||||
|
|
||||||
(define *weak-pixel-list* (make-integer-table))
|
|
||||||
|
|
||||||
(define (pixel-list-find Xpixel)
|
|
||||||
(let ((r (table-ref *weak-pixel-list* Xpixel)))
|
|
||||||
(if r
|
|
||||||
(weak-pointer-ref r)
|
|
||||||
r)))
|
|
||||||
|
|
||||||
(define (pixel-list-set! Xpixel pixel)
|
|
||||||
(let ((p (make-weak-pointer pixel)))
|
|
||||||
(table-set! *weak-pixel-list* Xpixel p)))
|
|
||||||
|
|
||||||
(define (pixel-list-delete! Xpixel)
|
|
||||||
(table-set! *weak-pixel-list* Xpixel #f))
|
|
||||||
|
|
@ -1,83 +0,0 @@
|
||||||
;; the window-datatype ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
|
|
||||||
(define-record-type window :window
|
|
||||||
(really-make-window tag Xwindow display)
|
|
||||||
window?
|
|
||||||
(tag window-tag window-set-tag!)
|
|
||||||
(Xwindow real-window-Xwindow window-set-Xwindow!)
|
|
||||||
(display window-display window-set-display!))
|
|
||||||
|
|
||||||
(define (window-Xwindow window)
|
|
||||||
(if (eq? window 'none)
|
|
||||||
none-resource
|
|
||||||
(real-window-Xwindow window)))
|
|
||||||
|
|
||||||
(define (make-window Xwindow display)
|
|
||||||
(if (null-resource? Xwindow)
|
|
||||||
'null
|
|
||||||
(let ((maybe-window (window-list-find Xwindow)))
|
|
||||||
(if maybe-window
|
|
||||||
maybe-window
|
|
||||||
(let ((window (really-make-window #f Xwindow display)))
|
|
||||||
(add-finalizer! window finalize-window)
|
|
||||||
(window-list-set! Xwindow window)
|
|
||||||
window)))))
|
|
||||||
|
|
||||||
(define-exported-binding "window-record-type" :window)
|
|
||||||
|
|
||||||
;; abstractions for a "drawable" which is a window or a pixmap.
|
|
||||||
|
|
||||||
(define (drawable? object)
|
|
||||||
(or (window? object)
|
|
||||||
(pixmap? object)))
|
|
||||||
|
|
||||||
(define (drawable-abstraction pixmap-fun window-fun)
|
|
||||||
(lambda (drawable)
|
|
||||||
(cond
|
|
||||||
((pixmap? drawable) (pixmap-fun drawable))
|
|
||||||
((window? drawable) (window-fun drawable))
|
|
||||||
(else (error "expected a drawable object" drawable)))))
|
|
||||||
|
|
||||||
(define drawable-display (drawable-abstraction pixmap-display window-display))
|
|
||||||
(define drawable-Xobject (drawable-abstraction pixmap-Xpixmap window-Xwindow))
|
|
||||||
|
|
||||||
;; finalize-window is called, when the garbage collector removes the last
|
|
||||||
;; reference to the window from the heap. Then we can savely close the window
|
|
||||||
;; and remove the weak-pointer from our list.
|
|
||||||
|
|
||||||
(define (finalize-window window)
|
|
||||||
(let ((Xwindow (window-Xwindow window)))
|
|
||||||
(destroy-window window)
|
|
||||||
(window-list-delete! Xwindow)))
|
|
||||||
|
|
||||||
;; ...
|
|
||||||
|
|
||||||
(define (destroy-window window)
|
|
||||||
(let ((Xdisplay (display-Xdisplay (window-display window)))
|
|
||||||
(Xwindow (window-Xwindow window)))
|
|
||||||
(if (integer? Xwindow)
|
|
||||||
(begin
|
|
||||||
(%destroy-window Xdisplay Xwindow)
|
|
||||||
(window-set-Xwindow! window 'already-destroyed)))))
|
|
||||||
|
|
||||||
(import-lambda-definition %destroy-window (Xdisplay Xwindow)
|
|
||||||
"Destroy_Window")
|
|
||||||
|
|
||||||
;; All window records need to be saved in a weak-list, to have only one record
|
|
||||||
;; for the same Xlib window-structure in the heap.
|
|
||||||
|
|
||||||
(define *weak-window-list* (make-integer-table))
|
|
||||||
|
|
||||||
(define (window-list-find Xwindow)
|
|
||||||
(let ((r (table-ref *weak-window-list* Xwindow)))
|
|
||||||
(if r
|
|
||||||
(weak-pointer-ref r)
|
|
||||||
r)))
|
|
||||||
|
|
||||||
(define (window-list-set! Xwindow window)
|
|
||||||
(let ((p (make-weak-pointer window)))
|
|
||||||
(table-set! *weak-window-list* Xwindow p)))
|
|
||||||
|
|
||||||
(define (window-list-delete! Xwindow)
|
|
||||||
(table-set! *weak-window-list* Xwindow #f))
|
|
||||||
|
|
||||||
Loading…
Reference in New Issue