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

made the mandatory arguments to create-gcontext (drawable) and 

create-window (parent width height) _really_ mandatory.
This commit is contained in:
frese 2001-08-29 14:47:03 +00:00
parent fd66d0396b
commit aa1926d027
2 changed files with 20 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
scheme/xlib/gcontext.scm
View File

@ -1,22 +1,21 @@
;; ...
(define (create-gcontext . args)
(define (create-gcontext drawable . args)
(let ((alist (named-args->alist args)))
(receive (drawable rest) (alist-split alist '((drawable . #f)))
(let* ((rest (map cons
(map car rest)
(map (lambda (obj)
(cond
((pixel? obj) (pixel-Xpixel obj))
((font? obj) (font-Xfont obj))
((pixmap? obj) (pixmap-Xpixmap obj))
(else obj)))
(map cdr rest))))
(display (drawable-display drawable))
(Xdisplay (display-Xdisplay display))
(Xobject (drawable-Xobject drawable)))
(let ((Xgcontext (%create-gcontext Xdisplay Xobject rest)))
(make-gcontext Xgcontext display #t))))))
(let* ((rest (map cons
(map car alist)
(map (lambda (obj)
(cond
((pixel? obj) (pixel-Xpixel obj))
((font? obj) (font-Xfont obj))
((pixmap? obj) (pixmap-Xpixmap obj))
(else obj)))
(map cdr alist))))
(display (drawable-display drawable))
(Xdisplay (display-Xdisplay display))
(Xobject (drawable-Xobject drawable)))
(let ((Xgcontext (%create-gcontext Xdisplay Xobject rest)))
(make-gcontext Xgcontext display #t)))))
(import-lambda-definition %create-gcontext (Xdisplay Xdrawable alist)
"scx_Create_Gc")

11
scheme/xlib/window.scm
View File

@ -2,15 +2,14 @@
;; create-window takes an alist of names and values - see
;; change-window-attributes and configure-window. Mandatory arguments for
;; create-window are 'parent, 'width and 'height. Example:
;; (create-window 'parent root 'width 500 'height 300 '((border-width . 4)))
;; create-window are parent, width and height. Example:
;; (create-window root 500 300 'x 0 '((border-width . 4)))
;; Returns the new window or raises an exception if something went wrong.
(define (create-window . args)
(define (create-window parent width height . args)
(let ((alist (named-args->alist args)))
(receive (x y width height border-width parent change-win-attr-list)
(alist-split alist '((x . 0) (y . 0) (width . #f) (height . #f)
(border-width . 2) (parent . #f)))
(receive (x y border-width change-win-attr-list)
(alist-split alist '((x . 0) (y . 0) (border-width . 2)))
(let* ((change-win-attr-list
(map cons
(map car change-win-attr-list)