Update of /cvsroot/scsh/scx/scheme/xlib
In directory usw-pr-cvs1:/tmp/cvs-serv13462
Modified Files:
colormap-type.scm cursor-type.scm display-type.scm
font-type.scm gcontext-type.scm pixmap-type.scm
window-type.scm
Log Message:
changed the constructors and finalizers, so that only one finalizer is
needed for each object.
Index: colormap-type.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/colormap-type.scm,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -r1.4 -r1.5
*** colormap-type.scm 2001/07/31 14:54:53 1.4
--- colormap-type.scm 2001/08/21 14:51:22 1.5
***************
*** 20,26 ****
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)))))
--- 20,26 ----
maybe-colormap
(let ((colormap (really-make-colormap #f Xcolormap display)))
(if finalize?
! (add-finalizer! colormap free-colormap)
! (add-finalizer! colormap colormap-list-delete!))
(colormap-list-set! Xcolormap colormap)
colormap)))))
***************
*** 30,33 ****
--- 30,34 ----
(if (integer? Xcolormap)
(begin
+ (colormap-list-delete! colormap)
(%free-colormap Xcolormap
(display-Xdisplay (colormap-display colormap)))
Index: cursor-type.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/cursor-type.scm,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -r1.2 -r1.3
*** cursor-type.scm 2001/07/31 14:54:53 1.2
--- cursor-type.scm 2001/08/21 14:51:22 1.3
***************
*** 18,24 ****
maybe-cursor
(let ((cursor (really-make-cursor #f Xcursor display)))
- (add-finalizer! cursor cursor-list-delete!)
(if finalize?
! (add-finalizer! cursor free-cursor))
(cursor-list-set! Xcursor cursor)
cursor)))))
--- 18,24 ----
maybe-cursor
(let ((cursor (really-make-cursor #f Xcursor display)))
(if finalize?
! (add-finalizer! cursor free-cursor)
! (add-finalizer! cursor cursor-list-delete!))
(cursor-list-set! Xcursor cursor)
cursor)))))
***************
*** 31,34 ****
--- 31,35 ----
(if (integer? Xcursor)
(begin
+ (cursor-list-delete! cursor)
(%free-cursor Xdisplay Xcursor)
(cursor-set-Xcursor! cursor 'already-destroyed)))))
Index: display-type.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/display-type.scm,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -r1.4 -r1.5
*** display-type.scm 2001/07/31 14:54:53 1.4
--- display-type.scm 2001/08/21 14:51:22 1.5
***************
*** 17,23 ****
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))))
--- 17,23 ----
maybe-display
(let ((display (really-make-display #f Xdisplay)))
(if finalize?
! (add-finalizer! display close-display)
! (add-finalizer! display display-list-delete!))
(display-list-set! Xdisplay display)
display))))
***************
*** 34,41 ****
(if (display-after-function display)
((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
--- 34,43 ----
(if (display-after-function display)
((display-after-function display) display))
+ (display-list-delete! display)
(%close-display Xdisplay)
(display-set-Xdisplay! display 'already-closed)))))
! (import-lambda-definition %close-display (Xdisplay)
! "scx_Close_Display")
;; All display records need to be saved in a weak-list, to have only one
record
Index: font-type.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/font-type.scm,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -r1.4 -r1.5
*** font-type.scm 2001/07/31 14:54:53 1.4
--- font-type.scm 2001/08/21 14:51:22 1.5
***************
*** 22,28 ****
(%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))))
--- 22,28 ----
(%Get_Xfont Xfontstruct)))
(font (really-make-font name Xfont Xfontstruct display)))
(if finalize?
! (add-finalizer! font unload-font)
! (add-finalizer! font font-list-delete!))
(font-list-set! Xfontstruct font)
font))))
***************
*** 54,58 ****
(Xdisplay (display-Xdisplay (font-display font))))
(if (integer? Xfontstruct)
! (%free-font Xdisplay Xfontstruct))
(font-set-Xfontstruct! font 'already-freed)
(font-set-Xfont! font 'already-freed)))
--- 54,60 ----
(Xdisplay (display-Xdisplay (font-display font))))
(if (integer? Xfontstruct)
! (begin
! (font-list-delete! font)
! (%free-font Xdisplay Xfontstruct)))
(font-set-Xfontstruct! font 'already-freed)
(font-set-Xfont! font 'already-freed)))
Index: gcontext-type.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/gcontext-type.scm,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -r1.3 -r1.4
*** gcontext-type.scm 2001/07/31 14:54:53 1.3
--- gcontext-type.scm 2001/08/21 14:51:22 1.4
***************
*** 18,24 ****
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)))))
--- 18,24 ----
maybe-gcontext
(let ((gcontext (really-make-gcontext #f Xgcontext display)))
(if finalize?
! (add-finalizer! gcontext free-gcontext)
! (add-finalizer! gcontext gcontext-list-delete!))
(gcontext-list-set! Xgcontext gcontext)
gcontext)))))
***************
*** 31,34 ****
--- 31,35 ----
(if (integer? Xgcontext)
(begin
+ (gcontext-list-delete! gcontext)
(%free-gcontext Xgcontext
(display-Xdisplay (gcontext-display gcontext)))
Index: pixmap-type.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/pixmap-type.scm,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -r1.4 -r1.5
*** pixmap-type.scm 2001/07/31 14:54:53 1.4
--- pixmap-type.scm 2001/08/21 14:51:22 1.5
***************
*** 20,26 ****
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)))))
--- 20,26 ----
maybe-pixmap
(let ((pixmap (really-make-pixmap #f Xpixmap display)))
(if finalize?
! (add-finalizer! pixmap free-pixmap)
! (add-finalizer! pixmap pixmap-list-delete!))
(pixmap-list-set! Xpixmap pixmap)
pixmap)))))
***************
*** 33,36 ****
--- 33,37 ----
(if (integer? Xpixmap)
(begin
+ (pixmap-list-delete! pixmap)
(%free-pixmap Xdisplay Xpixmap)
(pixmap-set-Xpixmap! pixmap 'already-destroyed)))))
Index: window-type.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/window-type.scm,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -r1.4 -r1.5
*** window-type.scm 2001/07/31 14:54:53 1.4
--- window-type.scm 2001/08/21 14:51:22 1.5
***************
*** 20,26 ****
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)))))
--- 20,26 ----
maybe-window
(let ((window (really-make-window #f Xwindow display)))
(if finalize?
! (add-finalizer! window destroy-window)
! (add-finalizer! window window-list-delete!))
(window-list-set! Xwindow window)
window)))))
|