scsh-conservatory
/
scx
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

fixed typos and forgotten parameters etc. fixed display-after-function.

This commit is contained in:
frese 2001-07-30 14:43:22 +00:00
parent cf6bc39491
commit 1e1cac1d34
14 changed files with 70 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
scheme/xlib/color.scm
View File

@ -37,9 +37,10 @@
(define (query-colors colormap pixels)
(let ((res (%query-colors (colormap-Xcolormap colormap)
(vector-map! pixel-Xpixel pixels))))
(vector-map! pixel-Xpixel pixels)
(display-Xdisplay (colormap-display colormap)))))
(vector-map! (lambda (r-g-b)
(apply make-color r-g-b))
(apply create-color r-g-b))
res)))
(import-lambda-definition %query-colors (Xcolormap Xpixels Xdisplay)

2
scheme/xlib/colormap-type.scm
View File

@ -26,7 +26,7 @@
colormap)))))
(define (free-colormap colormap)
(let ((Xcolormap (colormap-Xcolormap)))
(let ((Xcolormap (colormap-Xcolormap colormap)))
(if (integer? Xcolormap)
(begin
(%free-colormap Xcolormap

11
scheme/xlib/colormap.scm
View File

@ -23,9 +23,14 @@
(let ((Xres (%alloc-named-color (colormap-Xcolormap colormap)
(if (symbol? color-name)
(symbol->string color-name)
color-name))))
color-name)
(display-Xdisplay
(colormap-display colormap)))))
(if Xres
(list (make-pixel (car Xres))
(apply make-color (cadr Xres))
(apply make-color (caddr Xres)))
(apply create-color (cadr Xres))
(apply create-color (caddr Xres)))
Xres)))
(import-lambda-definition %alloc-named-color (Xcolormap name Xdisplay)
"Alloc_Named_Color")

12
scheme/xlib/display-type.scm
View File

@ -3,9 +3,14 @@
(define-record-type display :display
(really-make-display after-function Xdisplay)
display?
(after-function display-after-function display-set-after-function!)
(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)))
(if maybe-display
@ -26,9 +31,10 @@
(let ((Xdisplay (display-Xdisplay display)))
(if (integer? Xdisplay)
(begin
((display-after-function display) display)
(if (display-after-function display)
((display-after-function display) display))
(%close-display Xdisplay)
(display-set-Xdisplay display 'already-closed)))))
(display-set-Xdisplay! display 'already-closed)))))
(import-lambda-definition %close-display (Xdisplay) "Close_Display")

6
scheme/xlib/display.scm
View File

@ -29,7 +29,7 @@
(define (display-default-root-window display)
(let* ((Xdisplay (display-Xdisplay display))
(Xwindow (%default-root-window Xdisplay)))
(make-window Xwindow (make-display Xdisplay) #f)))
(make-window Xwindow (make-display Xdisplay #f) #f)))
;; for compatibility with Elk.
(define display-root-window display-default-root-window)
@ -234,7 +234,7 @@
(%display-wait-output (display-Xdisplay display)
discard-events?))
(import-lambda-definition %display-wait-ouput (Xdisplay discard)
(import-lambda-definition %display-wait-output (Xdisplay discard)
"Display_Wait_Output")
;; display-no-op sends a NoOperation protocol request to the X server, thereby
@ -254,7 +254,7 @@
(define (display-list-depths display screen-number)
(%display-list-depths (display-Xdisplay display)
(check-screen-number screen-number)))
(check-screen-number display screen-number)))
(import-lambda-definition %display-list-depths (Xdisplay scr)
"List_Depths")

2
scheme/xlib/drawable.scm
View File

@ -3,7 +3,7 @@
"Get_Geometry")
(define (get-geometry drawable)
(let ((display (drawable-display drawable))
(let* ((display (drawable-display drawable))
(v (%get-geometry (display-Xdisplay display)
(drawable-Xobject drawable))))
;; wrap the root-window

7
scheme/xlib/font-type.scm
View File

@ -2,10 +2,15 @@
(really-make-font name Xfont Xfontstruct display)
font?
(name font-name font-set-name!)
(Xfont font-Xfont font-set-Xfont!)
(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
;; from the Xfontstruct.

3
scheme/xlib/gcontext.scm
View File

@ -107,6 +107,7 @@
((pixmap? value) (pixmap-Xpixmap value))
((font? value) (font-Xfont value)) ;;??
((pixel? value) (pixel-Xpixel value))
;; ??...
(else value)))
(map cdr alist)))))
(%change-gcontext (gcontext-Xgcontext gcontext)
@ -114,7 +115,7 @@
prep-alist)))
(import-lambda-definition %change-gcontext (Xgcontext Xdisplay)
(import-lambda-definition %change-gcontext (Xgcontext Xdisplay args)
"Change_Gc")
(define (make-gcontext-setter name)

18
scheme/xlib/graphics.scm
View File

@ -3,7 +3,7 @@
;; last change : 04/07/2001
(define (clear-area window x y windth height exposures?)
(define (clear-area window x y width height exposures?)
(%clear-area (window-Xwindow window)
(display-Xdisplay (window-display window))
x y width height exposures?))
@ -138,7 +138,7 @@
(define (draw-rectangles drawable gcontext vector-of-rectangles)
(%draw-rectangles (display-Xdisplay (drawable-display drawable))
(drawable-object drawable)
(drawable-Xobject drawable)
(gcontext-Xgcontext gcontext)
vector-of-rectangles))
@ -149,7 +149,7 @@
(define (fill-rectangles drawable gcontext vector-of-rectangles)
(%fill-rectangles (display-Xdisplay (drawable-display drawable))
(drawable-object drawable)
(drawable-Xobject drawable)
(gcontext-Xgcontext gcontext)
vector-of-rectangles))
@ -160,7 +160,7 @@
(define (draw-arc drawable gcontext x y width height angle1 angle2)
(%draw-arc (display-Xdisplay (drawable-display drawable))
(drawable-object drawable)
(drawable-Xobject drawable)
(gcontext-Xgcontext gcontext)
x y width height angle1 angle2))
@ -169,9 +169,9 @@
"Draw_Arc")
(define (fill-arc drawable gcontext x y widht height angle1 angle2)
(define (fill-arc drawable gcontext x y width height angle1 angle2)
(%fill-arc (display-Xdisplay (drawable-display drawable))
(drawable-object drawable)
(drawable-Xobject drawable)
(gcontext-Xgcontext gcontext)
x y width height angle1 angle2))
@ -181,7 +181,7 @@
(define (draw-arcs drawable gcontext vector-of-data)
(%draw-arcs (display-Xdisplay (drawable-display drawable))
(drawable-object drawable)
(drawable-Xobject drawable)
(gcontext-Xgcontext gcontext)
vector-of-data))
@ -190,7 +190,7 @@
(define (fill-arcs drawable gcontext vector-of-data)
(%fill-arcs (display-Xdisplay (drawable-display drawable))
(drawable-object drawable)
(drawable-Xobject drawable)
(gcontext-Xgcontext gcontext)
vector-of-data))
@ -199,7 +199,7 @@
(define (fill-polygon drawable gcontext vector-of-points relative? shape)
(%fill-polygon (display-Xdisplay (drawable-display drawable))
(drawable-object drawable)
(drawable-Xobject drawable)
(gcontext-Xgcontext gcontext)
vector-of-points relative? shape))

16
scheme/xlib/pixel-type.scm
View File

@ -9,19 +9,10 @@
(if maybe-pixel
maybe-pixel
(let ((pixel (really-make-pixel #f Xpixel)))
(add-finalizer! pixel finalize-pixel)
(add-finalizer! pixel pixel-list-delete!)
(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
@ -37,5 +28,6 @@
(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))
(define (pixel-list-delete! pixel)
(table-set! *weak-pixel-list*
(pixel-Xpixel pixel) #f))

9
scheme/xlib/pixmap.scm
View File

@ -5,9 +5,10 @@
; ---
(define (create-pixmap drawable width height depth)
(let ((display (drawable-display drawable))
(let* ((display (drawable-display drawable))
(pixmap (%create-pixmap (display-Xdisplay display)
(drawable-Xdrawable) widht height depth)))
(drawable-Xobject drawable)
width height depth)))
(make-pixmap pixmap display #t)))
(import-lambda-definition %create-pixmap (Xdisplay Xdrawable w h depth)
@ -16,7 +17,7 @@
; ---
(define (create-bitmap-from-data window data width height)
(let ((display (window-display window))
(let* ((display (window-display window))
(Xpixmap (%create-bitmap-from-data (display-Xdisplay display)
(window-Xwindow window)
data width height)))
@ -29,7 +30,7 @@
(define (create-pixmap-from-bitmap-data win data widht height
foregrnd backgrnd depth)
(let ((display (window-display window))
(let* ((display (window-display window))
(pixmap (create-pixmap-from-bitmap-data (display-Xdisplay display)
(window-Xwindow window)
data widht height foregrnd

3
scheme/xlib/property.scm
View File

@ -110,10 +110,9 @@
"Set_Selection_Owner")
; --- (get-selection-owner instead of selection-owner)
; --- RETURN -> Window (s48 record)
(define (get-selection-owner display selection)
(define (selection-owner display selection)
(make-window (%get-selection-owner (display-Xdisplay display)
(atom-Xatom selection))
display

8
scheme/xlib/text.scm
View File

@ -30,8 +30,8 @@
(define (change-format format)
(cond ((symbol? format)
(cond ((eq? '1-byte) 1)
((eq? '2-byte) 2)
(cond ((eq? format '1-byte) 1)
((eq? format '2-byte) 2)
(else (error "Wrong format-type" change-format))))
((number? format)
(if (or (= 1 format) (= 2 format))
@ -105,11 +105,11 @@
(define (draw-poly-text drawable gcontext x y text format)
(let ((vec-text (transform-text text))
(int-format (change-format format))
(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)))
x y vec-text (change-format! format)))))
(import-lambda-definition %draw-poly-text (Xdisplay Xdrawable Xgcontext
x y text format)