Update of /cvsroot/scsh/scx/scheme/xlib/type
In directory usw-pr-cvs1:/tmp/cvs-serv24363
Modified Files:
color-type.scm colormap-type.scm pixel-type.scm
window-type.scm
Log Message:
Some changes.
Index: color-type.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/type/color-type.scm,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -r1.1 -r1.2
*** color-type.scm 2001/06/11 15:28:22 1.1
--- color-type.scm 2001/06/25 11:34:35 1.2
***************
*** 17,21 ****
;; r, g, b should be integers from 0 to 65535
! (define (make-color r g b)
(let ((maybe-color (color-list-find* r g b)))
(if maybe-color
--- 17,21 ----
;; 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
***************
*** 30,34 ****
;; returns a list of r,g,b as integers
(define (extract-rgb-values color)
! (%extract-rgb-values (color-Xcolor)))
(import-lambda-definition %extract-rgb-values (XColor)
--- 30,34 ----
;; 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)
Index: colormap-type.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/type/colormap-type.scm,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -r1.1 -r1.2
*** colormap-type.scm 2001/06/11 15:28:22 1.1
--- colormap-type.scm 2001/06/25 11:34:35 1.2
***************
*** 5,19 ****
colormap?
(tag colormap-tag colormap-set-tag!)
! (Xcolormap colormap-Xcolormap colormap-set-Xcolormap!)
(display colormap-display colormap-set-display!))
(define (make-colormap Xcolormap display)
! (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)
--- 5,26 ----
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)
***************
*** 26,30 ****
(let ((Xcolormap (colormap-Xcolormap colormap)))
(free-colormap colormap)
- (colormap-set-Xcolormap! colormap 'already-destroyed)
(colormap-list-delete! Xcolormap)))
--- 33,36 ----
Index: pixel-type.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/type/pixel-type.scm,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -r1.1 -r1.2
*** pixel-type.scm 2001/06/11 15:28:22 1.1
--- pixel-type.scm 2001/06/25 11:34:35 1.2
***************
*** 5,13 ****
(Xpixel pixel-Xpixel pixel-set-Xpixel!))
! (define (make-pixel Xpixel display)
(let ((maybe-pixel (pixel-list-find Xpixel)))
(if maybe-pixel
maybe-pixel
! (let ((pixel (really-make-pixel #f Xpixel display)))
(add-finalizer! pixel finalize-pixel)
(pixel-list-set! Xpixel pixel)
--- 5,13 ----
(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)
Index: window-type.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/type/window-type.scm,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -r1.1 -r1.2
*** window-type.scm 2001/06/11 15:28:22 1.1
--- window-type.scm 2001/06/25 11:34:35 1.2
***************
*** 5,25 ****
window?
(tag window-tag window-set-tag!)
! (Xwindow window-Xwindow window-set-Xwindow!)
(display window-display window-set-display!))
! (define (make-window tag Xwindow display)
! (let ((maybe-window (window-list-find Xwindow)))
! (if maybe-window
! maybe-window
! (let ((window (really-make-window tag Xwindow display)))
! (add-finalizer! window finalize-window)
! (window-list-set! Xwindow window)
! window))))
(define-exported-binding "window-record-type" :window)
(define (drawable? object)
(or (window? object)
(pixmap? object)))
;; finalize-window is called, when the garbage collector removes the last
--- 5,44 ----
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
|