Update of /cvsroot/scsh/scx/scheme/xlib
In directory usw-pr-cvs1:/tmp/cvs-serv1283
Modified Files:
color.scm colormap-type.scm colormap.scm display-type.scm
display.scm drawable.scm font-type.scm gcontext.scm
graphics.scm pixel-type.scm pixmap-type.scm pixmap.scm
property.scm text.scm
Log Message:
fixed typos and forgotten parameters etc. fixed display-after-function.
Index: color.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/color.scm,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -r1.4 -r1.5
*** color.scm 2001/07/19 15:07:12 1.4
--- color.scm 2001/07/30 14:43:22 1.5
***************
*** 38,44 ****
(define (query-colors colormap pixels)
(let ((res (%query-colors (colormap-Xcolormap colormap)
! (vector-map! pixel-Xpixel pixels))))
(vector-map! (lambda (r-g-b)
! (apply make-color r-g-b))
res)))
--- 38,45 ----
(define (query-colors colormap pixels)
(let ((res (%query-colors (colormap-Xcolormap colormap)
! (vector-map! pixel-Xpixel pixels)
! (display-Xdisplay (colormap-display colormap)))))
(vector-map! (lambda (r-g-b)
! (apply create-color r-g-b))
res)))
Index: colormap-type.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/colormap-type.scm,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -r1.2 -r1.3
*** colormap-type.scm 2001/07/19 15:21:09 1.2
--- colormap-type.scm 2001/07/30 14:43:22 1.3
***************
*** 27,31 ****
(define (free-colormap colormap)
! (let ((Xcolormap (colormap-Xcolormap)))
(if (integer? Xcolormap)
(begin
--- 27,31 ----
(define (free-colormap colormap)
! (let ((Xcolormap (colormap-Xcolormap colormap)))
(if (integer? Xcolormap)
(begin
Index: colormap.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/colormap.scm,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -r1.3 -r1.4
*** colormap.scm 2001/07/16 13:37:28 1.3
--- colormap.scm 2001/07/30 14:43:22 1.4
***************
*** 24,31 ****
(if (symbol? color-name)
(symbol->string color-name)
! color-name))))
(if Xres
(list (make-pixel (car Xres))
! (apply make-color (cadr Xres))
! (apply make-color (caddr Xres)))
Xres)))
--- 24,36 ----
(if (symbol? color-name)
(symbol->string color-name)
! color-name)
! (display-Xdisplay
! (colormap-display colormap)))))
(if Xres
(list (make-pixel (car Xres))
! (apply create-color (cadr Xres))
! (apply create-color (caddr Xres)))
Xres)))
+
+ (import-lambda-definition %alloc-named-color (Xcolormap name Xdisplay)
+ "Alloc_Named_Color")
\ No newline at end of file
Index: display-type.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/display-type.scm,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -r1.2 -r1.3
*** display-type.scm 2001/07/19 15:21:09 1.2
--- display-type.scm 2001/07/30 14:43:22 1.3
***************
*** 4,10 ****
(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 finalize?)
(let ((maybe-display (display-list-find Xdisplay)))
--- 4,15 ----
(really-make-display after-function Xdisplay)
display?
! (after-function display-after-function real-display-set-after-function!)
(Xdisplay display-Xdisplay display-set-Xdisplay!))
+ (define (display-set-after-function! display proc)
+ (let ((old (display-after-function display)))
+ (real-display-set-after-function! display proc)
+ old))
+
(define (make-display Xdisplay finalize?)
(let ((maybe-display (display-list-find Xdisplay)))
***************
*** 27,33 ****
(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")
--- 32,39 ----
(if (integer? Xdisplay)
(begin
! (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")
Index: display.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/display.scm,v
retrieving revision 1.5
retrieving revision 1.6
diff -C2 -r1.5 -r1.6
*** display.scm 2001/07/19 15:19:07 1.5
--- display.scm 2001/07/30 14:43:22 1.6
***************
*** 30,34 ****
(let* ((Xdisplay (display-Xdisplay display))
(Xwindow (%default-root-window Xdisplay)))
! (make-window Xwindow (make-display Xdisplay) #f)))
;; for compatibility with Elk.
--- 30,34 ----
(let* ((Xdisplay (display-Xdisplay display))
(Xwindow (%default-root-window Xdisplay)))
! (make-window Xwindow (make-display Xdisplay #f) #f)))
;; for compatibility with Elk.
***************
*** 235,239 ****
discard-events?))
! (import-lambda-definition %display-wait-ouput (Xdisplay discard)
"Display_Wait_Output")
--- 235,239 ----
discard-events?))
! (import-lambda-definition %display-wait-output (Xdisplay discard)
"Display_Wait_Output")
***************
*** 255,259 ****
(define (display-list-depths display screen-number)
(%display-list-depths (display-Xdisplay display)
! (check-screen-number screen-number)))
(import-lambda-definition %display-list-depths (Xdisplay scr)
--- 255,259 ----
(define (display-list-depths display screen-number)
(%display-list-depths (display-Xdisplay display)
! (check-screen-number display screen-number)))
(import-lambda-definition %display-list-depths (Xdisplay scr)
Index: drawable.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/drawable.scm,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -r1.2 -r1.3
*** drawable.scm 2001/07/19 15:14:29 1.2
--- drawable.scm 2001/07/30 14:43:22 1.3
***************
*** 4,10 ****
(define (get-geometry drawable)
! (let ((display (drawable-display drawable))
! (v (%get-geometry (display-Xdisplay display)
! (drawable-Xobject drawable))))
;; wrap the root-window
(vector-set! v 0 (make-window (vector-ref v 0) display #f))
--- 4,10 ----
(define (get-geometry drawable)
! (let* ((display (drawable-display drawable))
! (v (%get-geometry (display-Xdisplay display)
! (drawable-Xobject drawable))))
;; wrap the root-window
(vector-set! v 0 (make-window (vector-ref v 0) display #f))
Index: font-type.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/font-type.scm,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -r1.2 -r1.3
*** font-type.scm 2001/07/19 15:21:09 1.2
--- font-type.scm 2001/07/30 14:43:22 1.3
***************
*** 3,9 ****
font?
(name font-name font-set-name!)
! (Xfont font-Xfont font-set-Xfont!)
(Xfontstruct font-Xfontstruct font-set-Xfontstruct!)
(display font-display font-set-display!))
;; creates a font object. name can be #f. if Xfont is #f then it is obtained
--- 3,14 ----
font?
(name font-name font-set-name!)
! (Xfont real-font-Xfont font-set-Xfont!)
(Xfontstruct font-Xfontstruct font-set-Xfontstruct!)
(display font-display font-set-display!))
+
+ (define (font-Xfont font)
+ (if (none-resource? font)
+ 0
+ (real-font-Xfont font)))
;; creates a font object. name can be #f. if Xfont is #f then it is obtained
Index: gcontext.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/gcontext.scm,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -r1.4 -r1.5
*** gcontext.scm 2001/07/19 15:19:07 1.4
--- gcontext.scm 2001/07/30 14:43:22 1.5
***************
*** 108,111 ****
--- 108,112 ----
((font? value) (font-Xfont value)) ;;??
((pixel? value) (pixel-Xpixel value))
+ ;; ??...
(else value)))
(map cdr alist)))))
***************
*** 115,119 ****
! (import-lambda-definition %change-gcontext (Xgcontext Xdisplay)
"Change_Gc")
--- 116,120 ----
! (import-lambda-definition %change-gcontext (Xgcontext Xdisplay args)
"Change_Gc")
Index: graphics.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/graphics.scm,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -r1.2 -r1.3
*** graphics.scm 2001/07/09 13:49:38 1.2
--- graphics.scm 2001/07/30 14:43:22 1.3
***************
*** 4,8 ****
! (define (clear-area window x y windth height exposures?)
(%clear-area (window-Xwindow window)
(display-Xdisplay (window-display window))
--- 4,8 ----
! (define (clear-area window x y width height exposures?)
(%clear-area (window-Xwindow window)
(display-Xdisplay (window-display window))
***************
*** 139,143 ****
(define (draw-rectangles drawable gcontext vector-of-rectangles)
(%draw-rectangles (display-Xdisplay (drawable-display drawable))
! (drawable-object drawable)
(gcontext-Xgcontext gcontext)
vector-of-rectangles))
--- 139,143 ----
(define (draw-rectangles drawable gcontext vector-of-rectangles)
(%draw-rectangles (display-Xdisplay (drawable-display drawable))
! (drawable-Xobject drawable)
(gcontext-Xgcontext gcontext)
vector-of-rectangles))
***************
*** 150,154 ****
(define (fill-rectangles drawable gcontext vector-of-rectangles)
(%fill-rectangles (display-Xdisplay (drawable-display drawable))
! (drawable-object drawable)
(gcontext-Xgcontext gcontext)
vector-of-rectangles))
--- 150,154 ----
(define (fill-rectangles drawable gcontext vector-of-rectangles)
(%fill-rectangles (display-Xdisplay (drawable-display drawable))
! (drawable-Xobject drawable)
(gcontext-Xgcontext gcontext)
vector-of-rectangles))
***************
*** 161,165 ****
(define (draw-arc drawable gcontext x y width height angle1 angle2)
(%draw-arc (display-Xdisplay (drawable-display drawable))
! (drawable-object drawable)
(gcontext-Xgcontext gcontext)
x y width height angle1 angle2))
--- 161,165 ----
(define (draw-arc drawable gcontext x y width height angle1 angle2)
(%draw-arc (display-Xdisplay (drawable-display drawable))
! (drawable-Xobject drawable)
(gcontext-Xgcontext gcontext)
x y width height angle1 angle2))
***************
*** 170,176 ****
! (define (fill-arc drawable gcontext x y widht height angle1 angle2)
(%fill-arc (display-Xdisplay (drawable-display drawable))
! (drawable-object drawable)
(gcontext-Xgcontext gcontext)
x y width height angle1 angle2))
--- 170,176 ----
! (define (fill-arc drawable gcontext x y width height angle1 angle2)
(%fill-arc (display-Xdisplay (drawable-display drawable))
! (drawable-Xobject drawable)
(gcontext-Xgcontext gcontext)
x y width height angle1 angle2))
***************
*** 182,186 ****
(define (draw-arcs drawable gcontext vector-of-data)
(%draw-arcs (display-Xdisplay (drawable-display drawable))
! (drawable-object drawable)
(gcontext-Xgcontext gcontext)
vector-of-data))
--- 182,186 ----
(define (draw-arcs drawable gcontext vector-of-data)
(%draw-arcs (display-Xdisplay (drawable-display drawable))
! (drawable-Xobject drawable)
(gcontext-Xgcontext gcontext)
vector-of-data))
***************
*** 191,195 ****
(define (fill-arcs drawable gcontext vector-of-data)
(%fill-arcs (display-Xdisplay (drawable-display drawable))
! (drawable-object drawable)
(gcontext-Xgcontext gcontext)
vector-of-data))
--- 191,195 ----
(define (fill-arcs drawable gcontext vector-of-data)
(%fill-arcs (display-Xdisplay (drawable-display drawable))
! (drawable-Xobject drawable)
(gcontext-Xgcontext gcontext)
vector-of-data))
***************
*** 200,204 ****
(define (fill-polygon drawable gcontext vector-of-points relative? shape)
(%fill-polygon (display-Xdisplay (drawable-display drawable))
! (drawable-object drawable)
(gcontext-Xgcontext gcontext)
vector-of-points relative? shape))
--- 200,204 ----
(define (fill-polygon drawable gcontext vector-of-points relative? shape)
(%fill-polygon (display-Xdisplay (drawable-display drawable))
! (drawable-Xobject drawable)
(gcontext-Xgcontext gcontext)
vector-of-points relative? shape))
Index: pixel-type.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/pixel-type.scm,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -r1.1 -r1.2
*** pixel-type.scm 2001/07/09 13:45:36 1.1
--- pixel-type.scm 2001/07/30 14:43:22 1.2
***************
*** 10,26 ****
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
--- 10,17 ----
maybe-pixel
(let ((pixel (really-make-pixel #f Xpixel)))
! (add-finalizer! pixel pixel-list-delete!)
(pixel-list-set! Xpixel pixel)
pixel))))
;; All pixel records need to be saved in a weak-list, to have only one record
;; for the same XLib pixel
***************
*** 38,41 ****
(table-set! *weak-pixel-list* Xpixel p)))
! (define (pixel-list-delete! Xpixel)
! (table-set! *weak-pixel-list* Xpixel #f))
\ No newline at end of file
--- 29,33 ----
(table-set! *weak-pixel-list* Xpixel p)))
! (define (pixel-list-delete! pixel)
! (table-set! *weak-pixel-list*
! (pixel-Xpixel pixel) #f))
Index: pixmap-type.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/pixmap-type.scm,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -r1.2 -r1.3
*** pixmap-type.scm 2001/07/19 15:21:09 1.2
--- pixmap-type.scm 2001/07/30 14:43:22 1.3
***************
*** 56,58 ****
(define (pixmap-list-delete! pixmap)
(table-set! *weak-pixmap-list*
! (pixmap-Xpixmap pixmap) #f))
\ No newline at end of file
--- 56,58 ----
(define (pixmap-list-delete! pixmap)
(table-set! *weak-pixmap-list*
! (pixmap-Xpixmap pixmap) #f))
Index: pixmap.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/pixmap.scm,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -r1.3 -r1.4
*** pixmap.scm 2001/07/19 15:19:07 1.3
--- pixmap.scm 2001/07/30 14:43:22 1.4
***************
*** 6,13 ****
(define (create-pixmap drawable width height depth)
! (let ((display (drawable-display drawable))
! (pixmap (%create-pixmap (display-Xdisplay display)
! (drawable-Xdrawable) widht height depth)))
! (make-pixmap pixmap display #t)))
(import-lambda-definition %create-pixmap (Xdisplay Xdrawable w h depth)
--- 6,14 ----
(define (create-pixmap drawable width height depth)
! (let* ((display (drawable-display drawable))
! (pixmap (%create-pixmap (display-Xdisplay display)
! (drawable-Xobject drawable)
! width height depth)))
! (make-pixmap pixmap display #t)))
(import-lambda-definition %create-pixmap (Xdisplay Xdrawable w h depth)
***************
*** 17,24 ****
(define (create-bitmap-from-data window data width height)
! (let ((display (window-display window))
! (Xpixmap (%create-bitmap-from-data (display-Xdisplay display)
! (window-Xwindow window)
! data width height)))
(make-pixmap Xpixmap display #t)))
--- 18,25 ----
(define (create-bitmap-from-data window data width height)
! (let* ((display (window-display window))
! (Xpixmap (%create-bitmap-from-data (display-Xdisplay display)
! (window-Xwindow window)
! data width height)))
(make-pixmap Xpixmap display #t)))
***************
*** 30,38 ****
(define (create-pixmap-from-bitmap-data win data widht height
foregrnd backgrnd depth)
! (let ((display (window-display window))
! (pixmap (create-pixmap-from-bitmap-data (display-Xdisplay display)
! (window-Xwindow window)
! data widht height foregrnd
! backgrd depth)))
(make-pixmap pixmap display #t)))
--- 31,39 ----
(define (create-pixmap-from-bitmap-data win data widht height
foregrnd backgrnd depth)
! (let* ((display (window-display window))
! (pixmap (create-pixmap-from-bitmap-data (display-Xdisplay display)
! (window-Xwindow window)
! data widht height foregrnd
! backgrd depth)))
(make-pixmap pixmap display #t)))
***************
*** 63,68 ****
(error "zero or both coordinates must be defined"))
(else coord))))
! (%write-bitmap-file dpy filename pixmap widht height
! (car xy-hot) (cadr xy-hot))))
--- 64,69 ----
(error "zero or both coordinates must be defined"))
(else coord))))
! (%write-bitmap-file dpy filename pixmap widht height
! (car xy-hot) (cadr xy-hot))))
Index: property.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/property.scm,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -r1.2 -r1.3
*** property.scm 2001/07/19 15:19:07 1.2
--- property.scm 2001/07/30 14:43:22 1.3
***************
*** 111,118 ****
- ; --- (get-selection-owner instead of selection-owner)
; --- RETURN -> Window (s48 record)
! (define (get-selection-owner display selection)
(make-window (%get-selection-owner (display-Xdisplay display)
(atom-Xatom selection))
--- 111,117 ----
; --- RETURN -> Window (s48 record)
! (define (selection-owner display selection)
(make-window (%get-selection-owner (display-Xdisplay display)
(atom-Xatom selection))
Index: text.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/text.scm,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -r1.1 -r1.2
*** text.scm 2001/07/19 14:03:23 1.1
--- text.scm 2001/07/30 14:43:22 1.2
***************
*** 31,36 ****
(define (change-format format)
(cond ((symbol? format)
! (cond ((eq? '1-byte) 1)
! ((eq? '2-byte) 2)
(else (error "Wrong format-type" change-format))))
((number? format)
--- 31,36 ----
(define (change-format format)
(cond ((symbol? format)
! (cond ((eq? format '1-byte) 1)
! ((eq? format '2-byte) 2)
(else (error "Wrong format-type" change-format))))
((number? format)
***************
*** 106,114 ****
(define (draw-poly-text drawable gcontext x y text format)
(let ((vec-text (transform-text text))
! (int-format (change-format format))
(if (check-format? vec-text int-format)
(%draw-poly-text (display-Xdisplay (drawable-display drawable))
(drawable-Xobject drawable) (gcontext-Xgcontext
gcontext)
! x y vec-text (change-format! format)))
(import-lambda-definition %draw-poly-text (Xdisplay Xdrawable Xgcontext
--- 106,114 ----
(define (draw-poly-text drawable gcontext x y text format)
(let ((vec-text (transform-text text))
! (int-format (change-format format)))
(if (check-format? vec-text int-format)
(%draw-poly-text (display-Xdisplay (drawable-display drawable))
(drawable-Xobject drawable) (gcontext-Xgcontext
gcontext)
! x y vec-text (change-format! format)))))
(import-lambda-definition %draw-poly-text (Xdisplay Xdrawable Xgcontext
|