Update of /cvsroot/scsh/scx/scheme/xlib
In directory usw-pr-cvs1:/tmp/cvs-serv17464
Added Files:
color-type.scm colormap-type.scm display-type.scm
drawable-type.scm event-type.scm gcontext-type.scm
pixel-type.scm pixmap-type.scm window-type.scm
Log Message:
moved out of subdirecotry; some changes.
--- NEW FILE ---
;; 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")
;; 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))
--- NEW FILE ---
;; 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 (none-resource? colormap)
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)))))
;; 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))
--- NEW FILE ---
;; 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))))
;; 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))
;; The message port is used to efficiently check for pending messages, which
;; are then read normally with XNextEvent.
(define message-port #f)
(define (display-message-inport display)
(if message-port
message-port
(let* ((fd (%display-message-fd (display-Xdisplay display)))
(p (fdes->inport fd)))
(set! message-port p)
p)))
(import-lambda-definition %display-message-fd (Xdisplay)
"Display_Message_fd")
--- NEW FILE ---
;; 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))
--- NEW FILE ---
(define-record-type event-type :event
(make-event type args)
event?
(type event-type event-set-type!) ;a symbol
(args event-args event-set-args!)) ;a vector
--- NEW FILE ---
(define-record-type gcontext :gcontext
(really-make-gcontext tag Xgcontext display)
gcontext?
(tag gcontext-tag gcontext-set-tag!)
(Xgcontext real-gcontext-Xgcontext gcontext-set-Xgcontext!)
(display gcontext-display gcontext-set-display!))
(define (gcontext-Xgcontext gcontext)
(if (none-resource? gcontext)
0
(real-gcontext-Xgcontext gcontext)))
(define (make-gcontext Xgcontext display)
(if (= 0 Xgcontext)
none-resource
(let ((maybe-gcontext (gcontext-list-find Xgcontext)))
(if maybe-gcontext
maybe-gcontext
(let ((gcontext (really-make-gcontext #f Xgcontext display)))
(add-finalizer! gcontext finalize-gcontext)
(gcontext-list-set! Xgcontext gcontext)
gcontext)))))
;; finalize-gcontext is called, when the garbage collector removes the last
;; reference to the gcontext from the heap. Then we can savely close the
;; gcontext and remove the weak-pointer from our list.
(define (finalize-gcontext gcontext)
(let ((Xgcontext (gcontext-Xgcontext gcontext)))
(gcontext-set-Xgcontext! gcontext 'already-freed)
(gcontext-list-delete! Xgcontext)))
;; to free the gcontext X-lib ressources call free-gcontext. if gcontext is
;; already freed, the function does nothing.
(define (free-gcontext gcontext)
(let ((Xgcontext (gcontext-Xgcontext gcontext)))
(if (integer? Xgcontext)
(begin
(%free-gcontext Xgcontext
(display-Xdisplay (gcontext-display gcontext)))
(gcontext-set-Xgcontext! gcontext 'already-freed)))))
(import-lambda-definition %free-gcontext (Xgcontext Xdisplay)
"Free_Gc")
;; All gcontext records need to be saved in a weak-list, to have only one record
;; for the same XLib gcontext
(define *weak-gcontext-list* (make-integer-table))
(define (gcontext-list-find Xgcontext)
(let ((r (table-ref *weak-gcontext-list* Xgcontext)))
(if r
(weak-pointer-ref r)
r)))
(define (gcontext-list-set! Xgcontext gcontext)
(let ((p (make-weak-pointer gcontext)))
(table-set! *weak-gcontext-list* Xgcontext p)))
(define (gcontext-list-delete! Xgcontext)
(table-set! *weak-gcontext-list* Xgcontext #f))
--- NEW FILE ---
(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))))
;; 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))
--- NEW FILE ---
;; the window-datatype ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-record-type pixmap :pixmap
(really-make-pixmap tag Xpixmap display)
pixmap?
(tag pixmap-tag pixmap-set-tag!)
(Xpixmap real-pixmap-Xpixmap pixmap-set-Xpixmap!)
(display pixmap-display pixmap-set-display!))
(define (pixmap-Xpixmap pixmap)
(if (none-resource? pixmap)
0
(real-pixmap-Xpixmap pixmap)))
(define (make-pixmap Xpixmap display)
(if (= 0 Xpixmap)
none-resource
(let ((maybe-pixmap (pixmap-list-find Xpixmap)))
(if maybe-pixmap
maybe-pixmap
(let ((pixmap (really-make-pixmap #f Xpixmap display)))
(add-finalizer! pixmap finalize-pixmap)
(pixmap-list-set! Xpixmap pixmap)
pixmap)))))
;; finalize-pixmap is called, when the garbage collector removes the last
;; reference to the pixmap from the heap. Then we can savely close the pixmap
;; and remove the weak-pointer from our list.
(define (finalize-pixmap pixmap)
(let ((Xpixmap (pixmap-Xpixmap pixmap)))
(free-pixmap pixmap)
(pixmap-list-delete! Xpixmap)))
;; ...
(define (free-pixmap pixmap)
(let ((Xdisplay (display-Xdisplay (pixmap-display pixmap)))
(Xpixmap (pixmap-Xpixmap pixmap)))
(if (integer? Xpixmap)
(begin
(%free-pixmap Xdisplay Xpixmap)
(pixmap-set-Xpixmap! pixmap 'already-destroyed)))))
(import-lambda-definition %free-pixmap (Xdisplay Xpixmap)
"Free_Pixmap")
;; All pixmap records need to be saved in a weak-list, to have only one record
;; for the same Xlib pixmap-structure in the heap.
(define *weak-pixmap-list* (make-integer-table))
(define (pixmap-list-find Xpixmap)
(let ((r (table-ref *weak-pixmap-list* Xpixmap)))
(if r
(weak-pointer-ref r)
r)))
(define (pixmap-list-set! Xpixmap pixmap)
(let ((p (make-weak-pointer pixmap)))
(table-set! *weak-pixmap-list* Xpixmap p)))
(define (pixmap-list-delete! Xpixmap)
(table-set! *weak-pixmap-list* Xpixmap #f))
--- NEW FILE ---
;; 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 (none-resource? window)
0
(real-window-Xwindow window)))
(define (make-window Xwindow display)
(if (= 0 Xwindow)
none-resource
(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)))))
;; 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))
|