Update of /cvsroot/scsh/scx/scheme/xlib
In directory usw-pr-cvs1:/tmp/cvs-serv23565
Modified Files:
colormap-type.scm display-type.scm font-type.scm
gcontext-type.scm pixmap-type.scm window-type.scm
Log Message:
added the finalize? parameter to the constructor definitions.
Index: colormap-type.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/colormap-type.scm,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -r1.1 -r1.2
*** colormap-type.scm 2001/07/09 13:45:36 1.1
--- colormap-type.scm 2001/07/19 15:21:09 1.2
***************
*** 13,17 ****
(real-colormap-Xcolormap colormap)))
! (define (make-colormap Xcolormap display)
(if (none-resource? Xcolormap)
'none
--- 13,17 ----
(real-colormap-Xcolormap colormap)))
! (define (make-colormap Xcolormap display finalize?)
(if (none-resource? Xcolormap)
'none
***************
*** 20,36 ****
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)))
--- 20,29 ----
maybe-colormap
(let ((colormap (really-make-colormap #f Xcolormap display)))
! (add-finalizer! colormap colormap-list-delete!)
! (if finalize?
! (add-finalizer! colormap free-colormap))
(colormap-list-set! Xcolormap colormap)
colormap)))))
(define (free-colormap colormap)
(let ((Xcolormap (colormap-Xcolormap)))
***************
*** 59,63 ****
(table-set! *weak-colormap-list* Xcolormap p)))
! (define (colormap-list-delete! Xcolormap)
! (table-set! *weak-colormap-list* Xcolormap #f))
--- 52,57 ----
(table-set! *weak-colormap-list* Xcolormap p)))
! (define (colormap-list-delete! colormap)
! (table-set! *weak-colormap-list*
! (colormap-Xcolormap colormap) #f))
Index: display-type.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/display-type.scm,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -r1.1 -r1.2
*** display-type.scm 2001/07/09 13:45:36 1.1
--- display-type.scm 2001/07/19 15:21:09 1.2
***************
*** 7,28 ****
(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
--- 7,21 ----
(Xdisplay display-Xdisplay display-set-Xdisplay!))
! (define (make-display Xdisplay finalize?)
(let ((maybe-display (display-list-find Xdisplay)))
(if maybe-display
maybe-display
(let ((display (really-make-display #f Xdisplay)))
! (add-finalizer! display display-list-delete!)
! (if finalize?
! (add-finalizer! display close-display))
(display-list-set! Xdisplay display)
display))))
;; close-display closes the corresponding Xlib-display struct, by calling a
;; c-function and marks the scheme-record to be invalid (with the
***************
*** 55,60 ****
(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
--- 48,54 ----
(table-set! *weak-display-list* Xdisplay p)))
! (define (display-list-delete! display)
! (table-set! *weak-display-list*
! (display-Xdisplay display) #f))
;; The message port is used to efficiently check for pending messages, which
Index: font-type.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/font-type.scm,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -r1.1 -r1.2
*** font-type.scm 2001/07/18 15:48:22 1.1
--- font-type.scm 2001/07/19 15:21:09 1.2
***************
*** 10,14 ****
;; from the Xfontstruct.
! (define (make-font name Xfont Xfontstruct display)
(let ((maybe-font (font-list-find Xfontstruct)))
(if maybe-font
--- 10,14 ----
;; from the Xfontstruct.
! (define (make-font name Xfont Xfontstruct display finalize?)
(let ((maybe-font (font-list-find Xfontstruct)))
(if maybe-font
***************
*** 17,24 ****
(%Get_Xfont Xfontstruct)))
(font (really-make-font name Xfont Xfontstruct display)))
! (add-finalizer! font unload-font)
(font-list-set! Xfontstruct font)
font))))
;; load-font loads a font by its name. See XLoadQueryFont.
--- 17,29 ----
(%Get_Xfont Xfontstruct)))
(font (really-make-font name Xfont Xfontstruct display)))
! (add-finalizer! font font-list-delete!)
! (if finalize?
! (add-finalizer! font unload-font))
(font-list-set! Xfontstruct font)
font))))
+ (import-lambda-definition %Get_Xfont (Xfontstruct)
+ "Get_Xfont")
+
;; load-font loads a font by its name. See XLoadQueryFont.
***************
*** 28,32 ****
(symbol->string font-name)
font-name))))
! (make-font font-name #f Xfontstruct display)))
(import-lambda-definition %load-font (Xdisplay font_name)
--- 33,37 ----
(symbol->string font-name)
font-name))))
! (make-font font-name #f Xfontstruct display #t)))
(import-lambda-definition %load-font (Xdisplay font_name)
***************
*** 46,51 ****
(%free-font Xdisplay Xfontstruct))
(font-set-Xfontstruct! font 'already-freed)
! (font-set-Xfont! font 'already-freed)
! (font-list-delete! Xfont)))
;; for compatibility with Elk:
--- 51,56 ----
(%free-font Xdisplay Xfontstruct))
(font-set-Xfontstruct! font 'already-freed)
! (font-set-Xfont! font 'already-freed)))
!
;; for compatibility with Elk:
***************
*** 64,77 ****
(define *weak-font-list* (make-integer-table))
! (define (font-list-find Xfont)
! (let ((r (table-ref *weak-font-list* Xfont)))
(if r
(weak-pointer-ref r)
r)))
! (define (font-list-set! Xfont font)
(let ((p (make-weak-pointer font)))
! (table-set! *weak-font-list* Xfont p)))
! (define (font-list-delete! Xfont)
! (table-set! *weak-font-list* Xfont #f))
--- 69,83 ----
(define *weak-font-list* (make-integer-table))
! (define (font-list-find Xfontstruct)
! (let ((r (table-ref *weak-font-list* Xfontstruct)))
(if r
(weak-pointer-ref r)
r)))
! (define (font-list-set! Xfontstruct font)
(let ((p (make-weak-pointer font)))
! (table-set! *weak-font-list* Xfontstruct p)))
! (define (font-list-delete! font)
! (table-set! *weak-font-list*
! (font-Xfontstruct font) #f))
Index: gcontext-type.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/gcontext-type.scm,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -r1.1 -r1.2
*** gcontext-type.scm 2001/07/09 13:45:36 1.1
--- gcontext-type.scm 2001/07/19 15:21:09 1.2
***************
*** 11,15 ****
(real-gcontext-Xgcontext gcontext)))
! (define (make-gcontext Xgcontext display)
(if (= 0 Xgcontext)
none-resource
--- 11,15 ----
(real-gcontext-Xgcontext gcontext)))
! (define (make-gcontext Xgcontext display finalize?)
(if (= 0 Xgcontext)
none-resource
***************
*** 18,35 ****
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.
--- 18,28 ----
maybe-gcontext
(let ((gcontext (really-make-gcontext #f Xgcontext display)))
! (add-finalizer! gcontext gcontext-list-delete!)
! (if finalize?
! (add-finalizer! gcontext free-gcontext))
(gcontext-list-set! Xgcontext gcontext)
gcontext)))))
! ;; to free the gcontext X-lib ressources call free-gcontext. if gcontext is
;; already freed, the function does nothing.
***************
*** 60,63 ****
(table-set! *weak-gcontext-list* Xgcontext p)))
! (define (gcontext-list-delete! Xgcontext)
! (table-set! *weak-gcontext-list* Xgcontext #f))
\ No newline at end of file
--- 53,57 ----
(table-set! *weak-gcontext-list* Xgcontext p)))
! (define (gcontext-list-delete! gcontext)
! (table-set! *weak-gcontext-list*
! (gcontext-Xgcontext gcontext) #f))
\ No newline at end of file
Index: pixmap-type.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/pixmap-type.scm,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -r1.1 -r1.2
*** pixmap-type.scm 2001/07/09 13:45:36 1.1
--- pixmap-type.scm 2001/07/19 15:21:09 1.2
***************
*** 13,17 ****
(real-pixmap-Xpixmap pixmap)))
! (define (make-pixmap Xpixmap display)
(if (= 0 Xpixmap)
none-resource
--- 13,17 ----
(real-pixmap-Xpixmap pixmap)))
! (define (make-pixmap Xpixmap display finalize?)
(if (= 0 Xpixmap)
none-resource
***************
*** 20,36 ****
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)))
-
;; ...
--- 20,29 ----
maybe-pixmap
(let ((pixmap (really-make-pixmap #f Xpixmap display)))
! (add-finalizer! pixmap pixmap-list-delete!)
! (if finalize?
! (add-finalizer! pixmap free-pixmap))
(pixmap-list-set! Xpixmap pixmap)
pixmap)))))
;; ...
***************
*** 61,64 ****
(table-set! *weak-pixmap-list* Xpixmap p)))
! (define (pixmap-list-delete! Xpixmap)
! (table-set! *weak-pixmap-list* Xpixmap #f))
\ No newline at end of file
--- 54,58 ----
(table-set! *weak-pixmap-list* Xpixmap p)))
! (define (pixmap-list-delete! pixmap)
! (table-set! *weak-pixmap-list*
! (pixmap-Xpixmap pixmap) #f))
\ No newline at end of file
Index: window-type.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/window-type.scm,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -r1.2 -r1.3
*** window-type.scm 2001/07/16 13:37:28 1.2
--- window-type.scm 2001/07/19 15:21:09 1.3
***************
*** 13,17 ****
(real-window-Xwindow window)))
! (define (make-window Xwindow display)
(if (= 0 Xwindow)
none-resource
--- 13,17 ----
(real-window-Xwindow window)))
! (define (make-window Xwindow display finalize?)
(if (= 0 Xwindow)
none-resource
***************
*** 20,38 ****
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)))
-
;; The destroy-window function destroys the specified window as well as all
of
;; its subwindows and causes the X server to generate a destroy-notify event
for
--- 20,29 ----
maybe-window
(let ((window (really-make-window #f Xwindow display)))
! (add-finalizer! window window-list-delete!)
! (if finalize?
! (add-finalizer! window destroy-window))
(window-list-set! Xwindow window)
window)))))
;; The destroy-window function destroys the specified window as well as all
of
;; its subwindows and causes the X server to generate a destroy-notify event
for
***************
*** 65,69 ****
(table-set! *weak-window-list* Xwindow p)))
! (define (window-list-delete! Xwindow)
! (table-set! *weak-window-list* Xwindow #f))
--- 56,61 ----
(table-set! *weak-window-list* Xwindow p)))
! (define (window-list-delete! window)
! (table-set! *weak-window-list*
! (window-Xwindow window) #f))
|