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

+ Added support for visuals. 

+ Implemented some missing routines for color control:
create-colormap, alloc-color-cells, set-color-cell.
This commit is contained in:
frese 2001-09-20 14:41:01 +00:00
parent f6d39682a3
commit e7cce49d13
17 changed files with 431 additions and 634 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
c/xlib/Makefile
View File

@ -1,4 +1,4 @@
OBJECTS = main.o display.o window.o type.o color.o colormap.o pixel.o gcontext.o event.o pixmap.o graphics.o font.o cursor.o text.o property.o wm.o
OBJECTS = main.o display.o window.o type.o color.o colormap.o pixel.o gcontext.o event.o pixmap.o graphics.o font.o cursor.o text.o property.o wm.o client.o key.o error.o extension.o init.o util.o grab.o visual.o
$(OBJECTS): xlib.h
.c.o:

60
c/xlib/colormap.c
View File

@ -55,9 +55,69 @@ s48_value scx_Parse_Color (s48_value Xdpy, s48_value cmap, s48_value spec) {
return S48_FALSE;
}
s48_value scx_Create_Colormap (s48_value Xdisplay, s48_value Xwindow,
s48_value Xvisual, s48_value alloc) {
Colormap cm = XCreateColormap( SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_WINDOW(Xwindow),
SCX_EXTRACT_VISUAL(Xvisual),
S48_FALSE_P(alloc) ? AllocNone : AllocAll );
return SCX_ENTER_COLORMAP(cm);
}
s48_value scx_Alloc_Color_Cells (s48_value Xdisplay, s48_value Xcolormap,
s48_value contig, s48_value nplanes,
s48_value npixels) {
int npl = s48_extract_integer(nplanes);
int npx = s48_extract_integer(npixels);
unsigned long plane_masks[npl];
unsigned long pixels[npx];
s48_value pls = S48_FALSE, pxs = S48_FALSE;
S48_DECLARE_GC_PROTECT(2);
if (XAllocColorCells(SCX_EXTRACT_DISPLAY(Xdisplay),
SCX_EXTRACT_COLORMAP(Xcolormap),
!S48_FALSE_P(contig),
plane_masks, npl,
pixels, npx)) {
int i;
pls = s48_make_vector(npl, S48_FALSE);
pxs = s48_make_vector(npx, S48_FALSE);
S48_GC_PROTECT_2(pls, pxs);
for (i = 0; i < npl; i++)
S48_VECTOR_SET(pls, i, s48_enter_integer(plane_masks[i]));
for (i = 0; i < npx; i++)
S48_VECTOR_SET(pxs, i, s48_enter_integer(pixels[i]));
S48_GC_UNPROTECT();
return s48_cons(pls, pxs);
} else
return S48_FALSE;
}
s48_value scx_Set_Color_Cell(s48_value Xdisplay, s48_value Xcolormap,
s48_value Xpixel, s48_value Xcolor,
s48_value flags) {
XColor t;
XColor* c;
c = SCX_EXTRACT_COLOR(Xcolor);
t.pixel = SCX_EXTRACT_PIXEL(Xpixel);
t.red = c->red;
t.green = c->green;
t.blue = c->blue;
t.flags = Symbols_To_Bits(flags, Color_Flags_Syms);
XStoreColor(SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_COLORMAP(Xcolormap),
&t);
return S48_UNSPECIFIC;
}
void scx_init_colormap(void) {
S48_EXPORT_FUNCTION(scx_Free_Colormap);
S48_EXPORT_FUNCTION(scx_Alloc_Color);
S48_EXPORT_FUNCTION(scx_Alloc_Named_Color);
S48_EXPORT_FUNCTION(scx_Parse_Color);
S48_EXPORT_FUNCTION(scx_Create_Colormap);
S48_EXPORT_FUNCTION(scx_Alloc_Color_Cells);
S48_EXPORT_FUNCTION(scx_Set_Color_Cell);
}

6
c/xlib/display.c
View File

@ -84,6 +84,11 @@ s48_value scx_Display_Default_Screen_Number(s48_value Xdisplay) {
return s48_enter_integer(DefaultScreen(SCX_EXTRACT_DISPLAY(Xdisplay)));
}
s48_value scx_Display_Default_Visual(s48_value Xdisplay, s48_value scrnum) {
return SCX_ENTER_VISUAL( DefaultVisual( SCX_EXTRACT_DISPLAY(Xdisplay),
s48_extract_integer(scrnum) ));
}
s48_value scx_Display_Cells(s48_value Xdisplay, s48_value ScrNum) {
int num = (int)s48_extract_integer(ScrNum);
return s48_enter_integer(DisplayCells(SCX_EXTRACT_DISPLAY(Xdisplay), num));
@ -242,6 +247,7 @@ void scx_init_display(void) {
S48_EXPORT_FUNCTION(scx_Display_Default_Gcontext);
S48_EXPORT_FUNCTION(scx_Display_Default_Depth);
S48_EXPORT_FUNCTION(scx_Display_Default_Screen_Number);
S48_EXPORT_FUNCTION(scx_Display_Default_Visual);
S48_EXPORT_FUNCTION(scx_Display_Cells);
S48_EXPORT_FUNCTION(scx_Display_Planes);
S48_EXPORT_FUNCTION(scx_Display_String);

17
c/xlib/main.c
View File

@ -15,6 +15,15 @@ extern void scx_init_cursor();
extern void scx_init_text();
extern void scx_init_property();
extern void scx_init_wm();
extern void scx_init_client();
extern void scx_init_key();
extern void scx_init_error();
extern void scx_init_extension();
extern void scx_init_init();
extern void scx_init_util();
extern void scx_init_grab();
extern void scx_init_visual();
int main(){
s48_add_external_init(scx_init_window);
@ -33,6 +42,14 @@ int main(){
s48_add_external_init(scx_init_property);
s48_add_external_init(scx_init_cursor);
s48_add_external_init(scx_init_wm);
s48_add_external_init(scx_init_client);
s48_add_external_init(scx_init_key);
s48_add_external_init(scx_init_error);
s48_add_external_init(scx_init_extension);
s48_add_external_init(scx_init_init);
s48_add_external_init(scx_init_util);
s48_add_external_init(scx_init_grab);
s48_add_external_init(scx_init_visual);
s48_main(8000000, 64000,
"/afs/wsi/home/dfreese/i386_fbsd43/scsh-0.6/lib/scheme48/scsh.image",

BIN
c/xlib/test
View File

Binary file not shown.

455
c/xlib/type.c
View File

@ -481,451 +481,22 @@ SYMDESCR Error_Syms[] = {
{ 0, 0 }
};
/*************************************************************************
Other things
*************************************************************************/
/*
static s48_value Set_Attr_Slots;
static s48_value Conf_Slots;
static s48_value GC_Slots;
static s48_value Geometry_Slots;
static s48_value Win_Attr_Slots;
static s48_value Font_Info_Slots;
static s48_value Char_Info_Slots;
static s48_value Wm_Hints_Slots;
static s48_value Size_Hints_Slots;
static s48_value Sym_Parent_Relative, Sym_Copy_From_Parent;
XSetWindowAttributes SWA;
RECORD Set_Attr_Rec[] = {
{ (char *)&SWA.background_pixmap, "background-pixmap", T_BACKGROUND,
0, CWBackPixmap },
{ (char *)&SWA.background_pixel, "background-pixel", T_PIXEL,
0, CWBackPixel },
{ (char *)&SWA.border_pixmap, "border-pixmap", T_BORDER,
0, CWBorderPixmap },
{ (char *)&SWA.border_pixel, "border-pixel", T_PIXEL,
0, CWBorderPixel },
{ (char *)&SWA.bit_gravity, "bit-gravity", T_SYM,
Bit_Grav_Syms, CWBitGravity },
{ (char *)&SWA.win_gravity, "gravity", T_SYM,
Grav_Syms, CWWinGravity },
{ (char *)&SWA.backing_store, "backing-store", T_SYM,
Backing_Store_Syms, CWBackingStore },
{ (char *)&SWA.backing_planes, "backing-planes", T_PIXEL,
0, CWBackingPlanes },
{ (char *)&SWA.backing_pixel, "backing-pixel", T_PIXEL,
0, CWBackingPixel },
{ (char *)&SWA.save_under, "save-under", T_BOOL,
0, CWSaveUnder },
{ (char *)&SWA.event_mask, "event-mask", T_MASK,
Event_Syms, CWEventMask },
{ (char *)&SWA.do_not_propagate_mask, "do-not-propagate-mask", T_MASK,
Event_Syms, CWDontPropagate },
{ (char *)&SWA.override_redirect, "override-redirect", T_BOOL,
0, CWOverrideRedirect },
{ (char *)&SWA.colormap, "colormap", T_COLORMAP,
0, CWColormap },
{ (char *)&SWA.cursor, "cursor", T_CURSOR,
0, CWCursor },
{ 0, 0, T_NONE, 0, 0 }
SYMDESCR Visual_Class_Syms[] = {
{ "direct-color", DirectColor },
{ "gray-scale", GrayScale },
{ "pseudo-color", PseudoColor },
{ "static-color", StaticColor },
{ "static-gray", StaticGray },
{ "true-color", TrueColor },
{ 0, 0 }
};
int Set_Attr_Size = sizeof Set_Attr_Rec / sizeof (RECORD);
XWindowChanges WC;
RECORD Conf_Rec[] = {
{ (char *)&WC.x, "x", T_INT, 0, CWX },
{ (char *)&WC.y, "y", T_INT, 0, CWY },
{ (char *)&WC.width, "width", T_INT, 0, CWWidth },
{ (char *)&WC.height, "height", T_INT, 0, CWHeight },
{ (char *)&WC.border_width, "border-width", T_INT, 0, CWBorderWidth },
{ (char *)&WC.sibling, "sibling", T_WINDOW, 0, CWSibling },
{ (char *)&WC.stack_mode, "stack-mode", T_SYM, Stack_Mode_Syms,
CWStackMode },
{ 0, 0, T_NONE, 0, 0 }
SYMDESCR Color_Flags_Syms[] = {
{ "do-red", DoRed },
{ "do-green", DoGreen },
{ "do-blue", DoBlue },
{ 0, 0 }
};
int Conf_Size = sizeof Conf_Rec / sizeof (RECORD);
XGCValues GCV;
RECORD GC_Rec[] = {
{ (char *)&GCV.function, "function", T_SYM,
Func_Syms, GCFunction },
{ (char *)&GCV.plane_mask, "plane-mask", T_PIXEL,
0, GCPlaneMask },
{ (char *)&GCV.foreground, "foreground", T_PIXEL,
0, GCForeground },
{ (char *)&GCV.background, "background", T_PIXEL,
0, GCBackground },
{ (char *)&GCV.line_width, "line-width", T_INT,
0, GCLineWidth },
{ (char *)&GCV.line_style, "line-style", T_SYM,
Line_Style_Syms, GCLineStyle },
{ (char *)&GCV.cap_style, "cap-style", T_SYM,
Cap_Style_Syms, GCCapStyle },
{ (char *)&GCV.join_style, "join-style", T_SYM,
Join_Style_Syms, GCJoinStyle },
{ (char *)&GCV.fill_style, "fill-style", T_SYM,
Fill_Style_Syms, GCFillStyle },
{ (char *)&GCV.fill_rule, "fill-rule", T_SYM,
Fill_Rule_Syms, GCFillRule },
{ (char *)&GCV.arc_mode, "arc-mode", T_SYM,
Arc_Mode_Syms, GCArcMode },
{ (char *)&GCV.tile, "tile", T_PIXMAP,
0, GCTile },
{ (char *)&GCV.stipple, "stipple", T_PIXMAP,
0, GCStipple },
{ (char *)&GCV.ts_x_origin, "ts-x", T_INT,
0, GCTileStipXOrigin },
{ (char *)&GCV.ts_y_origin, "ts-y", T_INT,
0, GCTileStipYOrigin },
{ (char *)&GCV.font, "font", T_FONT,
0, GCFont },
{ (char *)&GCV.subwindow_mode, "subwindow-mode", T_SYM,
Subwin_Mode_Syms, GCSubwindowMode },
{ (char *)&GCV.graphics_exposures, "exposures", T_BOOL,
0, GCGraphicsExposures },
{ (char *)&GCV.clip_x_origin, "clip-x", T_INT,
0, GCClipXOrigin },
{ (char *)&GCV.clip_y_origin, "clip-y", T_INT,
0, GCClipYOrigin },
{ (char *)&GCV.clip_mask, "clip-mask", T_PIXMAP,
0, GCClipMask },
{ (char *)&GCV.dash_offset, "dash-offset", T_INT,
0, GCDashOffset },
{ (char *)&GCV.dashes, "dashes", T_s48_extract_char,
0, GCDashList },
{0, 0, T_NONE, 0, 0 }
};
int GC_Size = sizeof GC_Rec / sizeof (RECORD);
GEOMETRY GEO;
RECORD Geometry_Rec[] = {
{ (char *)&GEO.root, "root", T_WINDOW, 0, 0 },
{ (char *)&GEO.x, "x", T_INT, 0, 0 },
{ (char *)&GEO.y, "y", T_INT, 0, 0 },
{ (char *)&GEO.width, "width", T_INT, 0, 0 },
{ (char *)&GEO.height, "height", T_INT, 0, 0 },
{ (char *)&GEO.border_width, "border-width", T_INT, 0, 0 },
{ (char *)&GEO.depth, "depth", T_INT, 0, 0 },
{0, 0, T_NONE, 0, 0 }
};
int Geometry_Size = sizeof Geometry_Rec / sizeof (RECORD);
XWindowAttributes WA;
RECORD Win_Attr_Rec[] = {
{ (char *)&WA.x, "x", T_INT,
0, 0 },
{ (char *)&WA.y, "y", T_INT,
0, 0 },
{ (char *)&WA.width, "width", T_INT,
0, 0 },
{ (char *)&WA.height, "height", T_INT,
0, 0 },
{ (char *)&WA.border_width, "border-width", T_INT,
0, 0 },
{ (char *)&WA.depth, "depth", T_INT,
0, 0 },
{ (char *)&WA.visual, "visual", T_NONE,
0, 0 },
{ (char *)&WA.root, "root", T_WINDOW,
0, 0 },
#if defined(__cplusplus) || defined(c_plusplus)
{ (char *)&WA.c_class, "class", T_SYM,
#else
{ (char *)&WA.class, "class", T_SYM,
#endif
Class_Syms, 0 },
{ (char *)&WA.bit_gravity, "bit-gravity", T_SYM,
Bit_Grav_Syms, 0 },
{ (char *)&WA.win_gravity, "gravity", T_SYM,
Grav_Syms, 0 },
{ (char *)&WA.backing_store, "backing-store", T_SYM,
Backing_Store_Syms, 0 },
{ (char *)&WA.backing_planes, "backing-planes", T_PIXEL,
0, 0 },
{ (char *)&WA.backing_pixel, "backing-pixel", T_PIXEL,
0, 0 },
{ (char *)&WA.save_under, "save-under", T_BOOL,
0, 0 },
{ (char *)&WA.colormap , "colormap", T_COLORMAP,
0, 0 },
{ (char *)&WA.map_installed, "map-installed", T_BOOL,
0, 0 },
{ (char *)&WA.map_state, "map-state", T_SYM,
Map_State_Syms, 0 },
{ (char *)&WA.all_event_masks, "all-event-masks", T_MASK,
Event_Syms, 0 },
{ (char *)&WA.your_event_mask, "your-event-mask", T_MASK,
Event_Syms, 0 },
{ (char *)&WA.do_not_propagate_mask, "do-not-propagate-mask", T_MASK,
Event_Syms, 0 },
{ (char *)&WA.override_redirect, "override-redirect", T_BOOL,
0, 0 },
{ (char *)&WA.screen, "screen", T_NONE,
0, 0 },
{0, 0, T_NONE, 0, 0 }
};
int Win_Attr_Size = sizeof Win_Attr_Rec / sizeof (RECORD);
XFontStruct FI;
RECORD Font_Info_Rec[] = {
{ (char *)&FI.direction, "direction", T_SYM,
Direction_Syms, 0 },
{ (char *)&FI.min_char_or_byte2, "min-byte2", T_INT,
0, 0 },
{ (char *)&FI.max_char_or_byte2, "max-byte2", T_INT,
0, 0 },
{ (char *)&FI.min_byte1, "min-byte1", T_INT,
0, 0 },
{ (char *)&FI.max_byte1, "max-byte1", T_INT,
0, 0 },
{ (char *)&FI.all_chars_exist, "all-chars-exist?", T_BOOL,
0, 0 },
{ (char *)&FI.default_char, "default-char", T_INT,
0, 0 },
{ (char *)&FI.ascent, "ascent", T_INT,
0, 0 },
{ (char *)&FI.descent, "descent", T_INT,
0, 0 },
{0, 0, T_NONE, 0, 0 }
};
int Font_Info_Size = sizeof Font_Info_Rec / sizeof (RECORD);
XCharStruct CI;
RECORD Char_Info_Rec[] = {
{ (char *)&CI.lbearing, "lbearing", T_SHORT, 0, 0 },
{ (char *)&CI.rbearing, "rbearing", T_SHORT, 0, 0 },
{ (char *)&CI.width, "width", T_SHORT, 0, 0 },
{ (char *)&CI.ascent, "ascent", T_SHORT, 0, 0 },
{ (char *)&CI.descent, "descent", T_SHORT, 0, 0 },
{ (char *)&CI.attributes, "attributes", T_SHORT, 0, 0 },
{0, 0, T_NONE, 0, 0 }
};
int Char_Info_Size = sizeof Char_Info_Rec / sizeof (RECORD);
XWMHints WMH;
RECORD Wm_Hints_Rec[] = {
{ (char *)&WMH.input, "input?", T_BOOL,
0, InputHint },
{ (char *)&WMH.initial_state, "initial-state", T_SYM,
Initial_State_Syms, StateHint },
{ (char *)&WMH.icon_pixmap, "icon-pixmap", T_PIXMAP,
0, IconPixmapHint },
{ (char *)&WMH.icon_window, "icon-window", T_WINDOW,
0, IconWindowHint },
{ (char *)&WMH.icon_x, "icon-x", T_INT,
0, IconPositionHint },
{ (char *)&WMH.icon_y, "icon-y", T_INT,
0, IconPositionHint },
{ (char *)&WMH.icon_mask, "icon-mask", T_PIXMAP,
0, IconMaskHint },
{ (char *)&WMH.window_group, "window-group", T_WINDOW,
0, WindowGroupHint },
{0, 0, T_NONE, 0, 0 }
};
int Wm_Hints_Size = sizeof Wm_Hints_Rec / sizeof (RECORD);
XSizeHints SZH;
RECORD Size_Hints_Rec[] = {
{ (char *)&SZH.x, "x", T_INT, 0, PPosition },
{ (char *)&SZH.y, "y", T_INT, 0, PPosition },
{ (char *)&SZH.width, "width", T_INT, 0, PSize },
{ (char *)&SZH.height, "height", T_INT, 0, PSize },
{ (char *)&SZH.x, "x", T_INT, 0, USPosition },
{ (char *)&SZH.y, "y", T_INT, 0, USPosition },
{ (char *)&SZH.width, "width", T_INT, 0, USSize },
{ (char *)&SZH.height, "height", T_INT, 0, USSize },
{ (char *)&SZH.min_width, "min-width", T_INT, 0, PMinSize },
{ (char *)&SZH.min_height, "min-height", T_INT, 0, PMinSize },
{ (char *)&SZH.max_width, "max-width", T_INT, 0, PMaxSize },
{ (char *)&SZH.max_height, "max-height", T_INT, 0, PMaxSize },
{ (char *)&SZH.width_inc, "width-inc", T_INT, 0, PResizeInc },
{ (char *)&SZH.height_inc, "height-inc", T_INT, 0, PResizeInc },
{ (char *)&SZH.min_aspect.x, "min-aspect-x", T_INT, 0, PAspect },
{ (char *)&SZH.min_aspect.y, "min-aspect-y", T_INT, 0, PAspect },
{ (char *)&SZH.max_aspect.x, "max-aspect-x", T_INT, 0, PAspect },
{ (char *)&SZH.max_aspect.y, "max-aspect-y", T_INT, 0, PAspect },
{ (char *)&SZH.base_width, "base-width", T_INT, 0, PBaseSize },
{ (char *)&SZH.base_height, "base-height", T_INT, 0, PBaseSize },
{ (char *)&SZH.win_gravity, "gravity", T_SYM, Grav_Syms,
PWinGravity },
{0, 0, T_NONE, 0, 0 }
};
int Size_Hints_Size = sizeof Size_Hints_Rec / sizeof (RECORD);
unsigned long Vector_To_Record (v, len, sym, rp) s48_value v, sym;
register RECORD *rp; {
register s48_value *p;
unsigned long mask = 0;
Check_Type (v, T_Vector);
p = VECTOR(v)->data;
if (S48_VECTOR_LENGTH(v) != len && !S48_EQ_P(p[0], sym))
Primitive_Error ("invalid argument");
for ( ; rp->slot; rp++) {
++p;
if (rp->type == T_NONE || S48_NULL_P (*p))
continue;
switch (rp->type) {
case T_INT:
*(int *)rp->slot = (int)s48_extract_integer (*p); break;
case T_SHORT:
*(short *)rp->slot = (int)s48_extract_integer (*p); break;
case T_s48_extract_char:
*(char *)rp->slot = (int)s48_extract_integer (*p); break;
case T_PIXEL:
*(unsigned long *)rp->slot = Get_Pixel (*p); break;
case T_BACKGROUND:
if (S48_EQ_P(*p, Sym_None))
*(Pixmap *)rp->slot = None;
else if (S48_EQ_P(*p, Sym_Parent_Relative))
*(Pixmap *)rp->slot = ParentRelative;
else
*(Pixmap *)rp->slot = Get_Pixmap (*p);
break;
case T_BORDER:
if (S48_EQ_P(*p, Sym_Copy_From_Parent)) {
*(Pixmap *)rp->slot = CopyFromParent;
break;
}
// fall through
case T_PIXMAP:
*(Pixmap *)rp->slot = Get_Pixmap (*p); break;
case T_BOOL:
Check_Type (*p, T_Boolean);
*(Bool *)rp->slot = (Bool)(s48_extract_integer(*p));
break;
case T_FONT:
*(Font *)rp->slot = Get_Font (*p);
break;
case T_COLORMAP:
*(Colormap *)rp->slot = Get_Colormap (*p); break;
case T_CURSOR:
*(Cursor *)rp->slot = Get_Cursor (*p);
break;
case T_WINDOW:
break;
case T_MASK:
*(long *)rp->slot = Symbols_To_Bits (*p, 1, rp->syms);
break;
case T_SYM:
*(int *)rp->slot = (int)Symbols_To_Bits (*p, 0, rp->syms);
break;
default:
Panic ("vector->record");
}
mask |= rp->mask;
}
return mask;
}
s48_value Record_To_Vector (rp, len, sym, dpy, flags) s48_value sym;
register RECORD *rp; Display *dpy; unsigned long flags; {
register i;
s48_value v, x;
S48_DECLARE_GC_PROTECT(2);
v = S48_NULL;
S48_GC_PROTECT_2 (sym, v);
v = s48_make_vector (len, S48_NULL);
S48_VECTOR_SET(v, 0, sym;)
for (i = 1; rp->slot; i++, rp++) {
if (rp->type == T_NONE)
continue;
if (rp->mask && !(flags & rp->mask))
continue;
x = S48_NULL;
switch (rp->type) {
case T_INT:
x = s48_enter_integer (*(int *)rp->slot); break;
case T_SHORT:
x = s48_enter_integer (*(short *)rp->slot); break;
case T_s48_extract_char:
x = s48_enter_integer (*(char *)rp->slot); break;
case T_PIXEL:
x = Make_Pixel (*(unsigned long *)rp->slot); break;
case T_PIXMAP:
if (*(unsigned long *)rp->slot == ~0L)
x = Sym_None;
else
x = Make_Pixmap_Foreign (dpy, *(Pixmap *)rp->slot);
break;
case T_FONT:
if (*(unsigned long *)rp->slot == ~0L)
x = Sym_None;
else {
register XFontStruct *info;
Disable_Interrupts;
info = XQueryFont (dpy, *(Font *)rp->slot);
Enable_Interrupts;
x = Make_Font_Foreign (dpy, S48_FALSE, *(Font *)rp->slot, info);
}
break;
case T_BOOL:
x = *(Bool *)rp->slot ? S48_TRUE : S48_FALSE; break;
case T_COLORMAP:
x = Make_Colormap (0, dpy, *(Colormap *)rp->slot); break;
case T_WINDOW:
x = Make_Window (0, dpy, *(Window *)rp->slot); break;
case T_MASK:
x = Bits_To_Symbols (*(long *)rp->slot, 1, rp->syms);
break;
case T_SYM:
x = Bits_To_Symbols ((unsigned long)*(int *)rp->slot, 0, rp->syms);
break;
default:
Panic ("record->vector");
}
S48_VECTOR_SET(v, i, x;)
}
S48_GC_UNPROTECT;
return v;
}
static Init_Record (rec, size, name, var) RECORD *rec; char *name;
s48_value *var; {
s48_value list, tail, cell;
register i;
char buf[128];
S48_DECLARE_GC_PROTECT(2);
S48_GC_PROTECT_2 (list, tail);
for (list = tail = S48_NULL, i = 1; i < size; tail = cell, i++, rec++) {
cell = Intern (rec->name);
cell = s48_cons (cell, s48_enter_integer (i));
cell = s48_cons (cell, S48_NULL);
if (S48_NULL_P (list))
list = cell;
else
P_Set_S48_CDR (tail, cell);
}
sprintf (buf, "%s-slots", name);
Define_Variable (var, buf, list);
S48_GC_UNPROTECT;
}
elk_init_xlib_type () {
Init_Record (Set_Attr_Rec, Set_Attr_Size, "set-window-attributes",
&Set_Attr_Slots);
Init_Record (Conf_Rec, Conf_Size, "window-configuration", &Conf_Slots);
Init_Record (GC_Rec, GC_Size, "gcontext", &GC_Slots);
Init_Record (Geometry_Rec, Geometry_Size, "geometry", &Geometry_Slots);
Init_Record (Win_Attr_Rec, Win_Attr_Size, "get-window-attributes",
&Win_Attr_Slots);
Init_Record (Font_Info_Rec, Font_Info_Size, "font-info", &Font_Info_Slots);
Init_Record (Char_Info_Rec, Char_Info_Size, "char-info", &Char_Info_Slots);
Init_Record (Wm_Hints_Rec, Wm_Hints_Size, "wm-hints", &Wm_Hints_Slots);
Init_Record (Size_Hints_Rec, Size_Hints_Size, "size-hints",
&Size_Hints_Slots);
Define_Symbol (&Sym_Parent_Relative, "parent-relative");
Define_Symbol (&Sym_Copy_From_Parent, "copy-from-parent");
}
*/
void scx_init_type(void) {
S48_GC_PROTECT_GLOBAL(string_to_symbol_binding);

111
c/xlib/visual.c Normal file
View File

@ -0,0 +1,111 @@
#include "xlib.h"
s48_value Enter_Visual_Info(XVisualInfo* vi) {
s48_value t = s48_make_vector(10, S48_FALSE);
S48_DECLARE_GC_PROTECT(1);
S48_GC_PROTECT_1(t);
S48_VECTOR_SET(t, 0, SCX_ENTER_VISUAL(vi->visual));
S48_VECTOR_SET(t, 1, s48_enter_integer(vi->visualid));
S48_VECTOR_SET(t, 2, s48_enter_integer(vi->screen));
S48_VECTOR_SET(t, 3, s48_enter_integer(vi->depth));
S48_VECTOR_SET(t, 4, Bit_To_Symbol(vi->class, Visual_Class_Syms));
S48_VECTOR_SET(t, 5, s48_enter_integer(vi->red_mask));
S48_VECTOR_SET(t, 6, s48_enter_integer(vi->green_mask));
S48_VECTOR_SET(t, 7, s48_enter_integer(vi->blue_mask));
S48_VECTOR_SET(t, 8, s48_enter_integer(vi->colormap_size));
S48_VECTOR_SET(t, 9, s48_enter_integer(vi->bits_per_rgb));
S48_GC_UNPROTECT();
return t;
}
s48_value scx_Get_Visual_Info(s48_value Xdisplay, s48_value v) {
XVisualInfo template;
XVisualInfo* visualList;
int visualsMatch, i;
long mask = VisualNoMask;
s48_value res = S48_FALSE;
S48_DECLARE_GC_PROTECT(1);
for (i=1; i<10; i++) {
s48_value val = S48_VECTOR_REF(v, i);
if (!S48_FALSE_P(val)) {
switch (i) {
// 0 = visual is not allowed here.
case 1: {
template.visualid = s48_extract_integer(val);
mask |= VisualIDMask;
} break;
case 2: {
template.screen = s48_extract_integer(val);
mask |= VisualScreenMask;
} break;
case 3: {
template.depth = s48_extract_integer(val);
mask |= VisualDepthMask;
} break;
case 4: {
template.class = Symbol_To_Bit(val, Visual_Class_Syms);
mask |= VisualClassMask;
} break;
case 5: {
template.red_mask = s48_extract_integer(val);
mask |= VisualRedMaskMask;
} break;
case 6: {
template.green_mask = s48_extract_integer(val);
mask |= VisualGreenMaskMask;
} break;
case 7: {
template.blue_mask = s48_extract_integer(val);
mask |= VisualBlueMaskMask;
} break;
case 8: {
template.colormap_size = s48_extract_integer(val);
mask |= VisualColormapSizeMask;
} break;
case 9: {
template.bits_per_rgb = s48_extract_integer(val);
mask |= VisualBitsPerRGBMask;
} break;
}
}
}
visualList = XGetVisualInfo( SCX_EXTRACT_DISPLAY(Xdisplay),
mask, &template, &visualsMatch);
res = s48_make_vector(visualsMatch, S48_FALSE);
S48_GC_PROTECT_1(res);
for (i=0; i<visualsMatch; i++)
S48_VECTOR_SET(res, i, Enter_Visual_Info(&visualList[i]));
S48_GC_UNPROTECT();
return res;
}
s48_value scx_Visual_ID(s48_value Xvisual) {
return s48_enter_integer(XVisualIDFromVisual(SCX_EXTRACT_VISUAL(Xvisual)));
}
s48_value scx_Match_Visual_Info(s48_value Xdisplay, s48_value scrnum,
s48_value depth, s48_value class) {
XVisualInfo r;
if (XMatchVisualInfo(SCX_EXTRACT_DISPLAY(Xdisplay),
s48_extract_integer(scrnum),
s48_extract_integer(depth),
Symbol_To_Bit(class, Visual_Class_Syms),
&r))
return Enter_Visual_Info(&r);
else
return S48_FALSE;
}
void scx_init_visual(void) {
S48_EXPORT_FUNCTION(scx_Get_Visual_Info);
S48_EXPORT_FUNCTION(scx_Visual_ID);
S48_EXPORT_FUNCTION(scx_Match_Visual_Info);
}

9
c/xlib/window.c
View File

@ -88,13 +88,16 @@ int extract_border(s48_value value) {
}
s48_value scx_Create_Window (s48_value Xdisplay, s48_value Xparent, s48_value x,
s48_value y, s48_value width, s48_value height,
s48_value border_width, s48_value attrAlist) {
s48_value y, s48_value width, s48_value height,
s48_value border_width, s48_value Xvisual,
s48_value attrAlist) {
XSetWindowAttributes Xattrs;
unsigned long mask = AList_To_XSetWindowAttributes( attrAlist, &Xattrs );
Window win;
Visual* vis = S48_FALSE_P(Xvisual) ? CopyFromParent :
SCX_EXTRACT_VISUAL(Xvisual);
win = XCreateWindow( SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_WINDOW(Xparent),
(int)s48_extract_integer(x),
(int)s48_extract_integer(y),
@ -103,7 +106,7 @@ s48_value scx_Create_Window (s48_value Xdisplay, s48_value Xparent, s48_value x,
(int)s48_extract_integer (border_width),
CopyFromParent,
CopyFromParent,
CopyFromParent,
vis,
mask,
&Xattrs );
return SCX_ENTER_WINDOW(win);

186
c/xlib/xlib.h
View File

@ -2,9 +2,6 @@
#include <X11/Xlib.h>
#include <X11/Xutil.h>
//#undef S48_TRUE
//#undef S48_FALSE
#ifndef NeedFunctionPrototypes /* Kludge */
#error "X11 Release 3 (or earlier) no longer supported"
#endif
@ -53,114 +50,11 @@ extern char* s48_extract_symbol(s48_value);
#define SCX_EXTRACT_FONT(x) (Font)s48_extract_integer(x)
#define SCX_ENTER_FONTSTRUCT(x) s48_enter_integer((long)x)
#define SCX_EXTRACT_FONTSTRUCT(x) (XFontStruct*)s48_extract_integer(x)
// TODO:
#define SCX_ENTER_VISUAL(x) S48_FALSE
#define SCX_ENTER_VISUAL(x) s48_enter_integer((long)x)
#define SCX_EXTRACT_VISUAL(x) (Visual*)s48_extract_integer(x)
/*
extern int T_Display;
extern int T_Gc;
extern int T_Pixel;
extern int T_Pixmap;
extern int T_Window;
extern int T_Font;
extern int T_Colormap;
extern int T_Color;
extern int T_Cursor;
extern int T_Atom;
#define DISPLAY(x) ((struct S_Display *)POINTER(x))
#define GCONTEXT(x) ((struct S_Gc *)POINTER(x))
#define PIXEL(x) ((struct S_Pixel *)POINTER(x))
#define PIXMAP(x) ((struct S_Pixmap *)POINTER(x))
#define WINDOW(x) ((struct S_Window *)POINTER(x))
#define FONT(x) ((struct S_Font *)POINTER(x))
#define COLORMAP(x) ((struct S_Colormap *)POINTER(x))
#define COLOR(x) ((struct S_Color *)POINTER(x))
#define CURSOR(x) ((struct S_Cursor *)POINTER(x))
#define ATOM(x) ((struct S_Atom *)POINTER(x))
struct S_Display {
s48_value after;
Display *dpy;
char free;
};
struct S_Gc {
s48_value tag;
GC gc;
Display *dpy;
char free;
};
struct S_Pixel {
s48_value tag;
unsigned long pix;
};
struct S_Pixmap {
s48_value tag;
Pixmap pm;
Display *dpy;
char free;
};
struct S_Window {
s48_value tag;
Window win;
Display *dpy;
char free;
char finalize;
};
struct S_Font {
s48_value name;
Font id;
XFontStruct *info;
Display *dpy;
};
struct S_Colormap {
s48_value tag;
Colormap cm;
Display *dpy;
char free;
};
struct S_Color {
s48_value tag;
XColor c;
};
struct S_Cursor {
s48_value tag;
Cursor cursor;
Display *dpy;
char free;
};
struct S_Atom {
s48_value tag;
Atom atom;
};
enum Type {
T_NONE,
T_INT, T_s48_extract_char, T_PIXEL, T_PIXMAP, T_BOOL, T_FONT, T_COLORMAP, T_CURSOR,
T_WINDOW, T_MASK, T_SYM, T_SHORT, T_BACKGROUND, T_BORDER
};
*/
/*
typedef struct {
char *slot;
char *name;
enum Type type;
SYMDESCR *syms;
int mask;
} RECORD;
*/
extern unsigned long AList_To_XWindowChanges(s48_value alist,
XWindowChanges* WC);
typedef struct {
Window root;
@ -175,73 +69,6 @@ typedef struct {
/*
C_LINKAGE_BEGIN
extern Colormap Get_Colormap P_((Object));
extern Cursor Get_Cursor P_((Object));
extern Drawable Get_Drawable P_((Object, Display**));
extern Font Get_Font P_((Object));
extern int Get_Screen_Number P_((Display*, Object));
extern s48_value Get_Event_Args P_((XEvent*));
extern Pixmap Get_Pixmap P_((Object));
extern Time Get_Time P_((Object));
extern Window Get_Window P_((Object));
extern XColor *Get_Color P_((Object));
extern unsigned long Get_Pixel P_((Object));
extern void Destroy_Event_Args P_((Object));
extern int Encode_Event P_((Object));
extern int Match_X_Obj P_((ELLIPSIS));
extern void Open_Font_Maybe P_((Object));
extern s48_value Make_Atom P_((Atom));
extern s48_value Make_Color P_((unsigned int, unsigned int, unsigned int));
extern s48_value Make_Colormap P_((int, Display*, Colormap));
extern s48_value Make_Cursor P_((Display*, Cursor));
extern s48_value Make_Cursor_Foreign P_((Display*, Cursor));
extern s48_value Make_Display P_((int, Display*));
extern s48_value Make_Font P_((Display*, Object, Font, XFontStruct*));
extern s48_value Make_Font_Foreign P_((Display*, Object, Font, XFontStruct*));
extern s48_value Make_Gc P_((int, Display*, GC));
extern s48_value Make_Pixel P_((unsigned long));
extern s48_value Make_Pixmap P_((Display*, Pixmap));
extern s48_value Make_Pixmap_Foreign P_((Display*, Pixmap));
extern s48_value Make_Window P_((int, Display*, Window));
extern s48_value P_Close_Display P_((Object));
extern s48_value P_Close_Font P_((Object));
extern s48_value P_Destroy_Window P_((Object));
extern s48_value P_Free_Colormap P_((Object));
extern s48_value P_Free_Cursor P_((Object));
extern s48_value P_Free_Gc P_((Object));
extern s48_value P_Free_Pixmap P_((Object));
extern s48_value P_Window_Unique_Id P_((Object));
extern s48_value Record_To_Vector
P_((RECORD*, int, Object, Display*, unsigned long));
extern unsigned long Vector_To_Record P_((Object, int, Object, RECORD*));
C_LINKAGE_END
*/
/*
extern XSetWindowAttributes SWA;
extern XWindowChanges WC;
extern XGCValues GCV;
extern GEOMETRY GEO;
extern XWindowAttributes WA;
extern XFontStruct FI;
extern XCharStruct CI;
extern XWMHints WMH;
extern XSizeHints SZH;
extern Set_Attr_Size, Conf_Size, GC_Size, Geometry_Size, Win_Attr_Size,
Font_Info_Size, Char_Info_Size, Wm_Hints_Size, Size_Hints_Size;
*/
/*
extern RECORD Set_Attr_Rec[], Conf_Rec[], GC_Rec[], Geometry_Rec[],
Win_Attr_Rec[], Font_Info_Rec[], Char_Info_Rec[], Wm_Hints_Rec[],
Size_Hints_Rec[];
*/
extern SYMDESCR Func_Syms[], Bit_Grav_Syms[], Event_Syms[], Error_Syms[],
Grav_Syms[], Backing_Store_Syms[], Class_Syms[], Stack_Mode_Syms[],
Line_Style_Syms[], State_Syms[], Cap_Style_Syms[], Join_Style_Syms[],
@ -252,7 +79,4 @@ extern SYMDESCR Func_Syms[], Bit_Grav_Syms[], Event_Syms[], Error_Syms[],
Grabstatus_Syms[], Allow_Events_Syms[], Revert_Syms[], Polyshape_Syms[],
Initial_State_Syms[], Bitmapstatus_Syms[], Circulate_Syms[],
Ordering_Syms[], Byte_Order_Syms[], Saveset_Syms[], Closemode_Syms[],
Event_Mask_Syms[];
/*
extern s48_value Sym_None, Sym_Now, Sym_Char_Info, Sym_Conf;
*/
Event_Mask_Syms[], Visual_Class_Syms[], Color_Flags_Syms[];

59
scheme/xlib/colormap.scm
View File

@ -46,4 +46,61 @@
(import-lambda-definition %parse-color (Xdisplay Xcolormap string)
"scx_Parse_Color")
"scx_Parse_Color")
;; The create-colormap function creates a colormap of the specified
;; visual type for the screen on which the specified window resides.
;; alloc can be 'none or 'all. See XCreateColormap.
(define (create-colormap window visual alloc)
(let ((Xcolormap (%create-colormap (display-Xdisplay (window-display window))
(window-Xwindow window)
(visual-Xvisual visual)
(if (eq? alloc 'none)
#f
#t) ; 'all
)))
(make-colormap Xcolormap (window-display window) #t)))
(import-lambda-definition %create-colormap (Xdisplay Xwindow Xvisual alloc)
"scx_Create_Colormap")
;; The alloc-color-cells function allocates read/write color cells.
;; The number of colors must be positive and the number of planes
;; nonnegative, or a BadValue error results. See XAllocColorCells.
;; The return value is a pair who's car is the list of the planes
;; (integers), and who's cdr is a list of the pixels.
(define (alloc-color-cells colormap contigous nplanes npixels)
(let ((res (%alloc-color-cells (display-Xdisplay (colormap-display colormap))
(colormap-Xcolormap colormap)
contigous
nplanes npixels)))
(if res
(cons (vector->list (car res))
(map make-pixel
(vector->list (cdr res))))
res)))
(import-lambda-definition %alloc-color-cells (Xdisplay Xcolormap contig
nplanes npixels)
"scx_Alloc_Color_Cells")
;; The set-color-cell function uses XStoreColor(s) to set the content
;; of the color cell specified by pixel (a pixel is an index to a
;; colormap) to color. An optional parameter is a list of the symbols
;; 'do-red 'do-gree and 'do-blue, that specify which components of the
;; color should be used. It defaults to '(do-red do-green
;; do-blue). See XStoreColors.
(define (set-color-cell colormap pixel color . flags)
(%set-color-cell (display-Xdisplay (colormap-display colormap))
(colormap-Xcolormap colormap)
(pixel-Xpixel pixel) (color-Xcolor color)
(if (null? flags)
'(do-red do-green do-blue)
(car flags))))
(import-lambda-definition %set-color-cells (Xdisplay Xcolormap Xpixel Xcolor
flags)
"scx_Set_Color_Cell")

16
scheme/xlib/display.scm
View File

@ -83,6 +83,22 @@
(import-lambda-definition %default-screen-number (Xdisplay)
"scx_Display_Default_Screen_Number")
;; display-default-visual returns the default visual of the given
;; display. If no screen-number is specified the default screen is
;; used. See DisplayVisual.
(define (display-default-visual display . screen-number)
(make-visual
(%default-visual (display-Xdisplay display)
(if (null? screen-number)
(display-default-screen-number display)
(begin
(check-screen-number display (car screen-number))
(car screen-number))))))
(import-lambda-definition %default-visual (Xdisplay scr-num)
"scx_Display_Default_Visual")
;; internal function
(define (check-screen-number display screen-number)
(if (or (< screen-number 0)

33
scheme/xlib/visual-type.scm Normal file
View File

@ -0,0 +1,33 @@
(define-record-type visual :visual
(really-make-visual tag Xvisual)
visual?
(tag visual-tag visual-set-tag!)
(Xvisual visual-Xvisual visual-set-Xvisual!))
(define (make-visual Xvisual)
(let ((maybe-visual (visual-list-find Xvisual)))
(if maybe-visual
maybe-visual
(let ((visual (really-make-visual #f Xvisual)))
(add-finalizer! visual visual-list-delete!)
(visual-list-set! Xvisual visual)
visual))))
;; All visual records need to be saved in a weak-list, to have only one
;; record for the same XLib visual
(define *weak-visual-list* (make-integer-table))
(define (visual-list-find Xvisual)
(let ((r (table-ref *weak-visual-list* Xvisual)))
(if r
(weak-pointer-ref r)
r)))
(define (visual-list-set! Xvisual visual)
(let ((p (make-weak-pointer visual)))
(table-set! *weak-visual-list* Xvisual p)))
(define (visual-list-delete! visual)
(table-set! *weak-visual-list*
(visual-Xvisual visual) #f))

75
scheme/xlib/visual.scm Normal file
View File

@ -0,0 +1,75 @@
;; A visual information is an alist with the following keys:
;; 'screen-number the screen this visual belongs to
;; 'depth the depth of the screen
;; 'class one of 'direct-color 'gray-scale 'pseudo-color
;; 'static-color 'static-gray 'true-color
;; 'red-mask these masks are used for direct-color and true-color
;; 'green-mask to specify which bits of the pixel value specify
;; 'blue-mask red, green or blue values.
;; 'colormap-size tells how many different pixel value are valid
;; 'bits-per-rgb specifies how many bits in each of the red, green
;; and blue values in a colorcell are used to drive
;; the rgb gun in the screen.
;; 'visual this value can be passed to other functions, e.g.
;; create-window.
;; 'visual-id this value is not normally needed by applications.
;; returns a list of visual informations that match the template given
;; by args. args can consist of the same fields as a visual
;; information (see above) except 'visual that may not be
;; specified. But usually only the fields 'screen 'depth and 'class
;; make sense. See create-window for the syntax of args.
(define (get-visual-info display . args)
(let* ((alist (named-args->alist args))
(vector (pack-visual-info alist)))
(let ((res (%get-visual-info (display-Xdisplay display)
vector)))
(map unpack-visual-info
(vector->list res)))))
(import-lambda-definition %get-visual-info (Xdisplay v)
"scx_Get_Visual_Info")
(define (pack-visual-info vi)
(let ((mapping (map cons
'(visual visual-id screen-number depth class
red-mask green-mask blue-mask colormap-size
bits-per-rgb)
'(0 1 2 3 4 5 6 7 8 9)))
(r (make-vector 10 #f)))
(for-each (lambda (p)
(vector-set! r (cdr (assq (car p) mapping))
(cdr p)))
vi)
r))
(define (unpack-visual-info v)
(vector-set! v 0 (make-visual (vector-ref v 0)))
(map cons
'(visual visual-id screen-number depth class red-mask green-mask
blue-mask colormap-size bits-per-rgb)
(vector->list v)))
;; visual-id returns the id of a given visual.
(define (visual-id visual)
(%visual-id (visual-Xvisual visual)))
(import-lambda-definition %visual-id (Xvisual)
"scx_Visual_ID")
;; match-visual-info returns info on a matching visual or #f if none
;; exists.
(define (match-visual-info display screen-number depth class)
(let ((res (%match-visual-info (display-Xdisplay display)
screen-number
depth
class)))
(if res
(unpack-visual-info res)
res)))
(import-lambda-definition %match-visual-info (Xdisplay scrnum depth class)
"scx_Match_Visual_Info")

12
scheme/xlib/window.scm
View File

@ -8,8 +8,9 @@
(define (create-window parent width height . args)
(let ((alist (named-args->alist args)))
(receive (x y border-width change-win-attr-list)
(alist-split alist '((x . 0) (y . 0) (border-width . 2)))
(receive (x y border-width visual change-win-attr-list)
(alist-split alist '((x . 0) (y . 0) (border-width . 2)
(visual . #f)))
(let* ((change-win-attr-list
(map cons
(map car change-win-attr-list)
@ -25,13 +26,16 @@
(Xwindow (%create-window (display-Xdisplay display)
(window-Xwindow parent)
x y width height border-width
(if visual
(visual-Xvisual visual)
#f)
change-win-attr-list)))
(if (= Xwindow 0)
(error "cannot create window")
(make-window Xwindow display #t))))))
(import-lambda-definition %create-window (Xdisplay Xparent x y width height
border-width attrAlist)
border-width visual attrAlist)
"scx_Create_Window")
;; change-window-attributes takes an alist of names and values...
@ -105,7 +109,7 @@
(make-colormap Xcolormap
(window-display window)
#f)))
;; font, visual ??
(comp 6 make-visual) ;; visual
v))
(alist (map cons
'(x y width height border-width depth visual root

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

@ -14,6 +14,7 @@
display-default-gcontext
display-default-depth
display-default-screen-number
display-default-visual
display-cells
display-planes
display-string
@ -138,9 +139,12 @@
colormap?
free-colormap
colormap-display
alloc-color
alloc-color!
alloc-named-color
parse-color
alloc-color-cells
set-color-cell
create-colormap
))
(define-interface xlib-pixel-interface
@ -429,6 +433,13 @@
ungrab-server
;; syntax: with-server-grabbed
))
(define-interface xlib-visual-interface
(export visual?
get-visual-info
visual-id
match-visual-info
))
;; all together
@ -454,4 +465,5 @@
xlib-extension-interface
xlib-utility-interface
xlib-grab-interface
xlib-visual-interface
))

7
scheme/xlib/xlib-packages.scm
View File

@ -150,6 +150,12 @@
xlib-types)
(files grab))
(define-structure xlib-visual xlib-visual-interface
(open scheme
external-calls
xlib-types)
(files visual))
;; all together
(define-structure xlib xlib-interface
@ -174,5 +180,6 @@
xlib-extension
xlib-utility
xlib-grab
xlib-visual
)
(optimize auto-integrate))

3
scheme/xlib/xlib-type-package.scm
View File

@ -28,4 +28,5 @@
event-type
font-type
atom-type
cursor-type))
cursor-type
visual-type))