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

Only some small changes.

This commit is contained in:
frese 2001-06-25 11:46:06 +00:00
parent 374158d3a3
commit 45ffe04e5f
9 changed files with 399 additions and 79 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
c/xlib/color.c
View File

@ -16,9 +16,9 @@ s48_value Int_Extract_RGB_Values(XColor col) {
S48_DECLARE_GC_PROTECT(1);
S48_GC_PROTECT_1(res);
res = s48_cons( s48_enter_integer(col.red), res );
res = s48_cons( s48_enter_integer(col.green), res );
res = s48_cons( s48_enter_integer(col.blue), res );
res = s48_cons( s48_enter_integer(col.green), res );
res = s48_cons( s48_enter_integer(col.red), res );
S48_GC_UNPROTECT();
return res;

29
c/xlib/type.c
View File

@ -24,7 +24,7 @@ s48_value s48_enter_symbol(char* name) {
and the scheme symbols:
*/
s48_value Bits_To_Symbols(unsigned long bits, int mask_flag, SYMDESCR* table) {
s48_value Bits_To_Symbols(unsigned long bits, SYMDESCR* table) {
s48_value res = S48_NULL;
char* name;
int val;
@ -38,32 +38,29 @@ s48_value Bits_To_Symbols(unsigned long bits, int mask_flag, SYMDESCR* table) {
val = table[i].val;
if ((val & bits) != 0) {
if (mask_flag == 0) {
res = s48_enter_symbol(name);
break;
} else {
res = s48_cons(s48_enter_symbol(name), res);
}
res = s48_cons(s48_enter_symbol(name), res);
}
i++;
}
if ((mask_flag == 0) && S48_NULL_P(res))
res = s48_enter_integer(bits); // or an exception??
S48_GC_UNPROTECT();
return res;
}
unsigned long Symbols_To_Bits(s48_value Syms, int mask_flag, SYMDESCR* table) {
s48_value Bit_To_Symbol(unsigned long bits, SYMDESCR* table) {
s48_value res = Bits_To_Symbols(bits, table);
if (S48_NULL_P(res))
return s48_enter_integer(bits);
else
return S48_CAR(res);
}}
unsigned long Symbols_To_Bits(s48_value Syms, SYMDESCR* table) {
unsigned long res = 0;
s48_value l;
if (mask_flag) {
for (l = Syms; !S48_NULL_P(l); l = S48_CDR(l)) {
res |= Symbol_To_Bit(S48_CAR(l), table);
}
} else {
res |= Symbol_To_Bit(l, table);
for (l = Syms; !S48_NULL_P(l); l = S48_CDR(l)) {
res |= Symbol_To_Bit(S48_CAR(l), table);
}
return res;

56
c/xlib/window.c
View File

@ -28,13 +28,13 @@ unsigned long AList_To_XSetWindowAttributes(s48_value attrAlist,
Xattrs->border_pixel = s48_extract_integer(value);
mask |= CWBorderPixel;
} else if (cname == "bit-gravity") {
Xattrs->bit_gravity = Symbols_To_Bits(value, 0, Bit_Grav_Syms);
Xattrs->bit_gravity = Symbol_To_Bit(value, Bit_Grav_Syms);
mask |= CWBitGravity;
} else if (cname == "gravity") {
Xattrs->win_gravity = Symbols_To_Bits(value, 0, Grav_Syms);
Xattrs->win_gravity = Symbol_To_Bit(value, Grav_Syms);
mask |= CWWinGravity;
} else if (cname == "backing-store") {
Xattrs->backing_store = Symbols_To_Bits(value, 0, Backing_Store_Syms);
Xattrs->backing_store = Symbol_To_Bit(value, Backing_Store_Syms);
mask |= CWBackingStore;
} else if (cname == "backing-planes") {
Xattrs->backing_planes = s48_extract_integer(value);
@ -46,10 +46,10 @@ unsigned long AList_To_XSetWindowAttributes(s48_value attrAlist,
Xattrs->save_under = !S48_FALSE_P(value);
mask |= CWSaveUnder;
} else if (cname == "event-mask") {
Xattrs->event_mask = Symbols_To_Bits(value, 1, Event_Syms);
Xattrs->event_mask = Symbols_To_Bits(value, Event_Syms);
mask |= CWEventMask;
} else if (cname == "do-not-propagate-mask") {
Xattrs->do_not_propagate_mask = Symbols_To_Bits(value, 1, Event_Syms);
Xattrs->do_not_propagate_mask = Symbols_To_Bits(value, Event_Syms);
mask |= CWDontPropagate;
} else if (cname == "override-redirect") {
Xattrs->override_redirect = !S48_FALSE_P(value);
@ -142,24 +142,36 @@ s48_value Get_Window_Attributes(s48_value Xdisplay, s48_value Xwindow) {
s48_value res = S48_NULL;
S48_GC_PROTECT_1(res);
XGetWindowAttributes(dpy, win, &WA);
if (!XGetWindowAttributes(dpy, win, &WA))
res = S48_FALSE;
else {
// ... usw.
res = s48_cons( s48_enter_integer(WA.backing_planes), res);
res = s48_cons( Bits_To_Symbols(WA.backing_store, 1, Backing_Store_Syms),
res);
res = s48_cons( Bits_To_Symbols(WA.win_gravity, 1, Grav_Syms),
res);
res = s48_cons( Bits_To_Symbols(WA.bit_gravity, 1, Bit_Grav_Syms), res);
res = s48_cons( Bits_To_Symbols(WA.class, 1, Class_Syms), res);
res = s48_cons( s48_enter_integer(WA.root), res); // a Window !
res = s48_cons( s48_enter_integer((long)WA.visual), res); // a Visual* !
res = s48_cons( s48_enter_integer(WA.depth), res);
res = s48_cons( s48_enter_integer(WA.border_width), res);
res = s48_cons( s48_enter_integer(WA.height), res);
res = s48_cons( s48_enter_integer(WA.width), res);
res = s48_cons( s48_enter_integer(WA.y), res);
res = s48_cons( s48_enter_integer(WA.x), res);
// WA.screen - ignored in Elk
res = s48_cons( WA.overide_redirect ? S48_TRUE : S48_FALSE, res);
res = s48_cons( ENTER_MASK( WA.do_not_propagate_mask ), res);
res = s48_cons( ENTER_MASK( WA.your_event_mask ), res);
res = s48_cons( ENTER_MASK( WA.all_event_mask ), res);
res = s48_cons( Bit_To_Symbol( WA.map_state, Map_State_Syms), res);
res = s48_cons( WA.map_installed ? S48_TRUE : S48_FALSE, res);
res = s48_cons( ENTER_COLORMAP( WA.colormap ), res);
res = s48_cons( WA.save_under ? S48_TRUE : s48_FALSE );
res = s48_cons( ENTER_PIXEL(WA.backing_pixel), res);
res = s48_cons( s48_enter_integer(WA.backing_planes), res);
res = s48_cons( Bit_To_Symbol(WA.backing_store, Backing_Store_Syms),
res);
res = s48_cons( Bit_To_Symbol(WA.win_gravity, Grav_Syms),
res);
res = s48_cons( Bit_To_Symbol(WA.bit_gravity, Bit_Grav_Syms), res);
res = s48_cons( Bit_To_Symbol(WA.class, Class_Syms), res);
res = s48_cons( ENTER_WINDOW(WA.root), res);
res = s48_cons( ENTER_VISUAL(WA.visual), res);
res = s48_cons( s48_enter_integer(WA.depth), res);
res = s48_cons( s48_enter_integer(WA.border_width), res);
res = s48_cons( s48_enter_integer(WA.height), res);
res = s48_cons( s48_enter_integer(WA.width), res);
res = s48_cons( s48_enter_integer(WA.y), res);
res = s48_cons( s48_enter_integer(WA.x), res);
}
S48_GC_UNPROTECT();
return res;

2
scheme/xlib/display.scm
View File

@ -23,7 +23,7 @@
(define (display-default-root-window display)
(let* ((Xdisplay (display-Xdisplay display))
(Xwindow (%default-root-window Xdisplay)))
(make-window 0 Xwindow (make-display Xdisplay))))
(make-window Xwindow (make-display Xdisplay))))
(define display-root-window display-default-root-window)

22
scheme/xlib/drawable.scm Normal file
View File

@ -0,0 +1,22 @@
;(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))
;; not so sure with pixmap-root, not found in Elk.
(define drawable-root (drawable-abstraction (lambda (pixm)
(display-default-root-window
(pixmap-display pixm)))
window-root))
(define drawable-x (drawable-abstraction pixmap-x window-x))
(define drawable-y (drawable-abstraction pixmap-y window-y))
(define drawable-width (drawable-abstraction pixmap-width window-width))
(define drawable-height (drawable-abstraction pixmap-height window-height))
(define drawable-border-width (drawable-abstraction pixmap-border-width
window-border-width))
(define drawable-depth (drawable-abstraction pixmap-depth window-depth))

165
scheme/xlib/gcontext.scm Normal file
View File

@ -0,0 +1,165 @@
;; ...
(define (create-gcontext . args)
(let ((alist (named-args->alist args)))
(receive (drawable rest) (alist-split '((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))))))
(import-lambda-definition %create-gcontext (Xdisplay Xdrawable alist)
"Create_Gc")
;; ...
(define (copy-gcontext gcontext drawable)
(let* ((new-gcontext (create-gcontext 'drawable drawable))
(new-Xgcontext (gcontext-Xgcontext new-gcontext))
(Xgcontext (gcontext-Xgcontext gcontext))
(Xdisplay (display-Xdisplay (gcontext-display gcontext)))
(%copy-gcontext Xdisplay Xgcontext new-Xgcontext))
new-gcontext))
(import-lambda-definition %copy-gcontext (Xdisplay Xsource Xdest)
"Copy_Gc")
;; ...
(define (get-gcontext-values gcontext)
(let ((Xgcontext (gcontext-Xgcontext gcontext))
(Xdisplay (display-Xdisplay (gcontext-display gcontext))))
(let ((lst (%get-gcontext-values Xgcontext Xdisplay)))
(if (not lst)
(error "cannot get gcontext values." gcontext)
(let*
((alist (map cons
'(function plane-mask foreground background
line-width line-style cap-style join-style
fill-style arc-mode tile stipple ts-x ts-y font
subwindow-mode exposures clip-x clip-y clip-mask
dash-offset dashes)
lst))
(mod-alist (map (lambda (name-val)
(case (car name-val)
((plane-mask foreground background)
(cons (car name-val)
(make-pixel (cdr name-val))))
;((tile stipple clip-mask)
;(cons (car name-val)
; (make-pixmap (cdr name-val) dyp??)))
;((font) (cons (make-font ...??)))
(else name-val)))
alist))))
mod-alist))))
(import-lambda-defintion %get-gcontext-values (Xgcontext Xdisplay)
"Get_Gc_Values")
;;...
(define (make-gcontext-getter name)
(lambda (gcontext)
(cdr (assq name (get-gcontext-values gcontext)))))
(define gcontext-function (make-gcontext-getter 'function))
(define gcontext-plane-mask (make-gcontext-getter 'plane-mask))
(define gcontext-foreground (make-gcontext-getter 'foreground))
(define gcontext-background (make-gcontext-getter 'background))
(define gcontext-line-width (make-gcontext-getter 'line-width))
(define gcontext-line-style (make-gcontext-getter 'line-style))
(define gcontext-cap-style (make-gcontext-getter 'cap-style))
(define gcontext-join-style (make-gcontext-getter 'join-style))
(define gcontext-fill-style (make-gcontext-getter 'fill-style))
(define gcontext-arc-mode (make-gcontext-getter 'arc-mode))
(define gcontext-tile (make-gcontext-getter 'tile))
(define gcontext-stipple (make-gcontext-getter 'stipple))
(define gcontext-ts-x (make-gcontext-getter 'ts-x))
(define gcontext-ts-y (make-gcontext-getter 'ts-y))
(define gcontext-font (make-gcontext-getter 'font))
(define gcontext-subwindow-mode (make-gcontext-getter 'subwindow-mode))
(define gcontext-exposures (make-gcontext-getter 'exposures))
(define gcontext-clip-x (make-gcontext-getter 'clip-x))
(define gcontext-clip-y (make-gcontext-getter 'clip-y))
(define gcontext-clip-mask (make-gcontext-getter 'clip-mask))
(define gcontext-dash-offset (make-gcontext-getter 'dash-offset))
(define gcontext-dashes (make-gcontext-getter 'dashes))
;; ...
(define (change-gcontext gcontext . attrs)
(let* ((alist (named-args->alist attrs))
(prep-alist
(map cons
(map car alist)
(map (lambda (value)
(cond
((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)
(display-Xdisplay (gcontext-display gcontext))
prep-alist)))
(import-lambda-definiton %change-gcontext (Xgcontext Xdisplay)
"Change_Gc")
(define (make-gcontext-setter name)
(lambda (gcontext value)
(change-gcontext gcontext (cons name value))))
(define set-gcontext-function! (make-gcontext-setter 'function))
(define set-gcontext-plane-mask! (make-gcontext-setter 'plane-mask))
(define set-gcontext-foreground! (make-gcontext-setter 'foreground))
(define set-gcontext-background! (make-gcontext-setter 'background))
(define set-gcontext-line-width! (make-gcontext-setter 'line-width))
(define set-gcontext-line-style! (make-gcontext-setter 'line-style))
(define set-gcontext-cap-style! (make-gcontext-setter 'cap-style))
(define set-gcontext-join-style! (make-gcontext-setter 'join-style))
(define set-gcontext-fill-style! (make-gcontext-setter 'fill-style))
(define set-gcontext-fill-rule! (make-gcontext-setter 'fill-rule))
(define set-gcontext-arc-mode! (make-gcontext-setter 'arc-mode))
(define set-gcontext-tile! (make-gcontext-setter 'tile))
(define set-gcontext-stipple! (make-gcontext-setter 'stipple))
(define set-gcontext-ts-x! (make-gcontext-setter 'ts-x))
(define set-gcontext-ts-y! (make-gcontext-setter 'ts-y))
(define set-gcontext-font! (make-gcontext-setter 'font))
(define set-gcontext-subwindow-mode! (make-gcontext-setter 'subwindow-mode))
(define set-gcontext-exposures! (make-gcontext-setter 'exposures))
(define set-gcontext-clip-x! (make-gcontext-setter 'clip-x))
(define set-gcontext-clip-y! (make-gcontext-setter 'clip-y))
(define set-gcontext-clip-mask! (make-gcontext-setter 'clip-mask))
(define set-gcontext-dash-offset! (make-gcontext-setter 'dash-offset))
(define set-gcontext-dashes! (make-gcontext-setter 'dashes))
;; set-dashlist! is a more complex form of set-dashes!. (set-dashes! N) is
;; equivalent to (set-dash-list! .. #(N N))
(define (set-gcontext-dashlist! gcontext dash-offset dash-list)
(%set-dashlist (gcontext-Xgcontext gcontext)
(display-Xdisplay (gcontext-display gcontext))
dash-offset
dash-list))
(import-lambda-definiton %set-dashlist (Xgcontext Xdisplay dashoffset dashlist)
"Set_Dashlist")
;; ...
(define (set-gcontext-clip-rectangles! gcontext x y rectangles ordering)
...)

25
scheme/xlib/stuff.scm
View File

@ -16,4 +16,27 @@
(cddr args)))))))
(define-exported-binding "string->symbol" string->symbol)
(define-exported-binding "string->symbol" string->symbol)
;; alist-split returns multiple values. the first values are all associations
;; of the keys. and additionaly the "rest" of the alist as one value.
(define (alist-split alist key-def-list)
(let ((keys (map car key-def-list)))
(let ((vals (map (lambda (key)
(let ((v (assq key alist)))
(if v v (assq key key-def-list))))
keys))
(rest (fold-right (lambda (this rest)
(if (memq (car this) keys)
rest
(cons this rest)))
'()
alist)))
(apply values (append vals (list rest))))))
;; according to the XLib constant "Null" which is defined as "0L"
(define null-resource? zero?)
(define null-resource 0)

67
scheme/xlib/window.scm
View File

@ -4,26 +4,9 @@
(define (create-window . args)
(let ((alist (named-args->alist args)))
;; filter attributes
(let* ((x 0)
(y 0)
(width #f)
(height #f)
(border-width 2)
(parent #f)
(change-win-attr-list '()))
(for-each (lambda (name-val)
(let ((val (cdr name-val)))
(case (car name-val)
((x) (set! x val))
((y) (set! y val))
((width) (set! width val))
((height) (set! height val))
((parent) (set! parent val))
((border-width) (set! border-width val))
(else (set! change-win-attr-list
(cons name-val change-win-attr-list))))))
alist)
(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)))
(let* ((display (window-display parent))
(Xwindow (%create-window (display-Xdisplay display)
(window-Xwindow parent)
@ -31,7 +14,7 @@
change-win-attr-list)))
(if (= Xwindow 0)
(error "cannot create window")
(make-window #f Xwindow display))))))
(make-window Xwindow display))))))
(import-lambda-definition %create-window (Xdisplay Xparent x y width height
border-width attrAlist)
@ -95,20 +78,34 @@
(define (get-window-attributes window)
(let ((Xwindow (window-Xwindow window))
(Xdisplay (display-Xdisplay (window-display window))))
(let* ((lst (%get-window-attributes Xdisplay Xwindow))
(alist (map cons
'(x y width height border-width depth visual root class
bit-gravity win-gravity backing-store backing-planes
backing-pixel save-under colormap map-installed
map-state all-event-masks your-event-mask
do-not-propagate-mask override-redirect screen)
lst))
(mod-alist (map (lambda (name-val)
(case (car name-val)
;((root) (make-window ...
(else name-val)))
alist)))
mod-alist)))
(let ((lst (%get-window-attributes Xdisplay Xwindow)))
(if (not lst)
(error "cannot get window attributes." window)
(let*
((alist (map cons
'(x y width height border-width depth visual root
class bit-gravity win-gravity backing-store
backing-planes backing-pixel save-under colormap
map-installed map-state all-event-masks
your-event-mask do-not-propagate-mask
override-redirect
; screen not supported
)
lst))
(mod-alist (map (lambda (name-val)
(case (car name-val)
;((...-mask))
;((font) ...)
((backing-pixel)
(cons 'backing-pixel
(make-pixel (cdr name-val))))
;((root)
; (cons 'root
; (make-window (cdr name-val) dpy??)))
;((visual) ??)
(else name-val)))
alist)))
mod-alist)))))
(import-lambda-definition %get-window-attributes (Xdisplay Xwindow)
"Get_Window_Attributes")

108
scheme/xlib/xlib-interfaces.scm
View File

@ -16,6 +16,9 @@
window-set-tag!
window-Xwindow
window-display
drawable-abstraction
drawable-display
drawable-Xobject
make-color
color?
@ -34,6 +37,13 @@
pixel?
pixel-Xpixel
pixel-tag
make-gcontext
gcontext?
gcontext-display
free-gcontext
gcontext-Xgcontext
gcontext-tag
))
@ -49,7 +59,8 @@
type/window-type
type/color-type
type/colormap-type
type/pixel-type))
type/pixel-type
type/gcontext-type))
;;; Basic package
@ -190,12 +201,31 @@
(open scsh
scheme
external-calls
receiving
xlib-types
xlib-basic
; xlib-graphics ;; for clear-window
xlib-graphics ;; for clear-window
)
(files window))
;;; the display-interface
(define-interface xlib-drawable-interface
(export drawable?
drawable-root
drawable-x
drawable-y
drawable-width
drawable-height
drawable-border-width
drawable-depth))
(define-structure xlib-drawable xlib-drawable-interface
(open scsh
scheme
xlib-types)
(files drawable))
;;; the color-interface
(define-interface xlib-color-interface
@ -251,3 +281,77 @@
black-pixel
white-pixel
))
;;; the gcontext-interface
(define-interface xlib-gcontext-interface
(open scsh
scheme
external-calls
receiving
xlib-types
xlib-basic)
(files gcontext))
(define-structure xlib-gcontext xlib-gcontext-interface
(export gcontext?
gcontext-display
create-gcontext
copy-gcontext
free-gcontext
query-best-size
query-best-cursor
query-best-title
query-best-stipple
gcontext-function
gcontext-plane-mask
gcontext-foreground
gcontext-background
gcontext-line-width
gcontext-line-style
gcontext-cap-style
gcontext-join-style
gcontext-fill-style
gcontext-fill-rule
gcontext-arc-mode
gcontext-tile
gcontext-stipple
gcontext-ts-x
gcontext-ts-y
gcontext-font
gcontext-subwindow-mode
gcontext-exposures
gcontext-clip-x
gcontext-clip-y
gcontext-clip-mask
gcontext-dash-offset
gcontext-dashes
set-gcontext-function!
set-gcontext-plane-mask!
set-gcontext-foreground!
set-gcontext-background!
set-gcontext-line-width!
set-gcontext-line-style!
set-gcontext-cap-style!
set-gcontext-join-style!
set-gcontext-fill-style!
set-gcontext-fill-rule!
set-gcontext-arc-mode!
set-gcontext-tile!
set-gcontext-stipple!
set-gcontext-ts-x!
set-gcontext-ts-y!
set-gcontext-font!
set-gcontext-subwindow-mode!
set-gcontext-exposures!
set-gcontext-clip-x!
set-gcontext-clip-y!
set-gcontext-clip-mask!
set-gcontext-dash-offset!
set-gcontext-clip-rectangles!
set-gcontext-dashlist!
))