implemented the functions for scx.

This commit is contained in:
frese 2001-07-18 15:44:41 +00:00
parent 95d78bf9bb
commit 3a18c650e5
1 changed files with 164 additions and 269 deletions

View File

@ -1,299 +1,194 @@
#include "xlib.h" #include "xlib.h"
#include "scheme48.h"
s48_value Sym_Char_Info;
static s48_value Sym_Font_Info, Sym_Min, Sym_Max;
Generic_Predicate (Font) s48_value Load_Font(s48_value Xdisplay, s48_value font_name) {
return ENTER_FONTSTRUCT(XLoadQueryFont(EXTRACT_DISPLAY(Xdisplay),
static Font_Equal (x, y) s48_value x, y; { s48_extract_string(font_name)));
Font id1 = FONT(x)->id, id2 = FONT(y)->id;
if (id1 && id2)
return id1 == id2 && FONT(x)->dpy == FONT(y)->dpy;
else
return 0;
} }
Generic_Print (Font, "#[font %lu]", FONT(x)->id ? FONT(x)->id : POINTER(x)) s48_value Free_Font(s48_value Xdisplay, s48_value Xfontstruct) {
XFreeFont(EXTRACT_DISPLAY(Xdisplay),
static Font_Visit (fp, f) s48_value *fp; int (*f)(); { EXTRACT_FONTSTRUCT(Xfontstruct));
(*f)(&FONT(*fp)->name); return S48_UNSPECIFIC;
} }
Generic_Get_Display (Font, FONT) s48_value Get_Xfont(s48_value Xfontstruct) {
return ENTER_FONT((EXTRACT_FONTSTRUCT(Xfontstruct))->fid);
static s48_value Internal_Make_Font (finalize, dpy, name, id, info)
Display *dpy; s48_value name; Font id; XFontStruct *info; {
s48_value f;
S48_DECLARE_GC_PROTECT(1);
S48_GC_PROTECT_1 (name);
f = Alloc_Object (sizeof (struct S_Font), T_Font, 0);
FONT(f)->dpy = dpy;
if (TYPE(name) == T_Symbol)
name = s48_extract_string(S48_SYMBOL_TO_STRING(name));
FONT(f)->name = name;
FONT(f)->id = id;
FONT(f)->info = info;
if (id)
Register_Object (f, (GENERIC)dpy, finalize ? P_Close_Font : (PFO)0, 0);
S48_GC_UNPROTECT;
return f;
} }
/* Backwards compatibility: */ s48_value GContext_Font(s48_value Xdisplay, s48_value Xgcontext) {
s48_value Make_Font (dpy, name, id, info) GContext gc = XGContextFromGC(EXTRACT_GCONTEXT(Xgcontext));
Display *dpy; s48_value name; Font id; XFontStruct *info; { Display* dpy = EXTRACT_DISPLAY(Xdisplay);
return Internal_Make_Font (1, dpy, name, id, info); return ENTER_FONTSTRUCT(XQueryFont(dpy, gc));
} }
s48_value Make_Font_Foreign (dpy, name, id, info) s48_value Font_Path(s48_value Xdisplay) {
Display *dpy; s48_value name; Font id; XFontStruct *info; { int n, i;
return Internal_Make_Font (0, dpy, name, id, info); char** sa;
s48_value ret;
S48_DECLARE_GC_PROTECT(1);
// Enable/Disable Interrupts ??
sa = XGetFontPath(EXTRACT_DISPLAY(Xdisplay), &n);
ret = s48_make_vector(n, S48_FALSE);
S48_GC_PROTECT_1(ret);
for (i = 0; i < n; i++) {
S48_VECTOR_SET(ret, i, s48_enter_string(sa[i]));
}
S48_GC_UNPROTECT();
XFreeFontPath(sa);
return ret;
} }
Font Get_Font (f) s48_value f; { s48_value Set_Font_Path(s48_value Xdisplay, s48_value path) {
Check_Type (f, T_Font); int i, n = S48_VECTOR_LENGTH(path);
Open_Font_Maybe (f); char* sa[n];
return FONT(f)->id;
for (i = 0; i < n; i++) {
sa[i] = s48_extract_string(S48_VECTOR_REF(path, i));
}
XSetFontPath(EXTRACT_DISPLAY(Xdisplay), sa, n);
return S48_UNSPECIFIC;
}
s48_value List_Font_Names(s48_value Xdisplay, s48_value pattern) {
char** sa;
int i,n;
s48_value v;
S48_DECLARE_GC_PROTECT(1);
XListFonts(EXTRACT_DISPLAY(Xdisplay),
s48_extract_string(pattern),
65535,
&n);
v = s48_make_vector(n, S48_FALSE);
S48_GC_PROTECT_1(v);
for (i = 0; i < n; i++) {
S48_VECTOR_SET(v, i, s48_enter_string(sa[i]));
}
S48_GC_UNPROTECT();
XFreeFontNames(sa);
return v;
} }
static XFontStruct *Internal_Open_Font (d, name) Display *d; s48_value name; { s48_value List_Fonts(s48_value Xdisplay, s48_value pattern) {
register char *s; char** sa;
XFontStruct *p; XFontStruct* fsa;
Alloca_Begin; int i,n;
s48_value v;
S48_DECLARE_GC_PROTECT(1);
Get_Strsym_Stack (name, s); XListFontsWithInfo(EXTRACT_DISPLAY(Xdisplay),
Disable_Interrupts; s48_extract_string(pattern),
if ((p = XLoadQueryFont (d, s)) == 0) 65535,
Primitive_Error ("cannot open font: ~s", name); &n,
Enable_Interrupts; &fsa);
Alloca_End;
return p; v = s48_make_vector(n, S48_FALSE);
S48_GC_PROTECT_1(v);
for (i = 0; i < n; i++) {
S48_VECTOR_SET(v, i, s48_cons(s48_enter_string(sa[i]),
ENTER_FONTSTRUCT(&fsa[i])));
}
S48_GC_UNPROTECT();
XFreeFontNames(sa);
return v;
} }
static s48_value P_Open_Font (d, name) s48_value d, name; { s48_value Font_Properties(s48_value Xfontstruct) {
XFontStruct *p; s48_value v;
int i,n;
XFontStruct* fs = EXTRACT_FONTSTRUCT(Xfontstruct);
XFontProp* p;
S48_DECLARE_GC_PROTECT(1);
Check_Type (d, T_Display) n = fs->n_properties;
p = Internal_Open_Font (DISPLAY(d)->dpy, name); v = s48_make_vector(n, S48_FALSE);
return Make_Font (DISPLAY(d)->dpy, name, p->fid, p); S48_GC_PROTECT_1(v);
for (i = 0; i < n; i++) {
p = fs->properties+i;
S48_VECTOR_SET(v, i, s48_cons( ENTER_ATOM(p->name),
s48_enter_integer(p->card32) ));
}
S48_GC_UNPROTECT();
return v;
} }
void Open_Font_Maybe (f) s48_value f; { s48_value Font_Property(s48_value Xfontstruct, s48_value Xatom) {
s48_value name; unsigned long val;
XFontStruct *p; if (XGetFontProperty(EXTRACT_FONTSTRUCT(Xfontstruct),
EXTRACT_ATOM(Xatom),
name = FONT(f)->name; &val))
if (!S48_TRUE_P (name)) return s48_enter_integer(val);
Primitive_Error ("invalid font"); else
if (FONT(f)->id == 0) { return S48_FALSE;
p = Internal_Open_Font (FONT(f)->dpy, name);
FONT(f)->id = p->fid;
FONT(f)->info = p;
Register_Object (f, (GENERIC)(FONT(f)->dpy), P_Close_Font, 0);
}
} }
s48_value P_Close_Font (f) s48_value f; { s48_value Font_Info(s48_value Xfontstruct) {
Check_Type (f, T_Font); XFontStruct* fs = EXTRACT_FONTSTRUCT(Xfontstruct);
if (FONT(f)->id) s48_value v = s48_make_vector(9, S48_FALSE);
XUnloadFont (FONT(f)->dpy, FONT(f)->id); S48_DECLARE_GC_PROTECT(1);
FONT(f)->id = 0; S48_GC_PROTECT_1(v);
Deregister_Object (f);
return Void; S48_VECTOR_SET(v, 0, Bit_To_Symbol(fs->direction, Direction_Syms));
S48_VECTOR_SET(v, 1, s48_enter_integer(fs->min_char_or_byte2));
S48_VECTOR_SET(v, 2, s48_enter_integer(fs->max_char_or_byte2));
S48_VECTOR_SET(v, 3, s48_enter_integer(fs->min_byte1));
S48_VECTOR_SET(v, 4, s48_enter_integer(fs->max_byte1));
S48_VECTOR_SET(v, 5, S48_ENTER_BOOLEAN(fs->all_chars_exist));
S48_VECTOR_SET(v, 6, s48_enter_integer(fs->default_char));
S48_VECTOR_SET(v, 7, s48_enter_integer(fs->ascent));
S48_VECTOR_SET(v, 8, s48_enter_integer(fs->descent));
S48_GC_UNPROTECT();
return v;
} }
static s48_value P_Font_Name (f) s48_value f; { static s48_value Char_Info(s48_value Xfontstruct, s48_value index) {
Check_Type (f, T_Font); // index must be an integer, #f for 'min or #t for 'max
return FONT(f)->name; XCharStruct* cp;
} XFontStruct* p = EXTRACT_FONTSTRUCT(Xfontstruct);
s48_value v;
S48_DECLARE_GC_PROTECT(1);
static s48_value P_Gcontext_Font (g) s48_value g; { if (S48_FALSE_P(index))
register struct S_Gc *p; cp = &p->min_bounds;
register XFontStruct *info; else if (S48_TRUE_P(index))
Check_Type (g, T_Gc);
p = GCONTEXT(g);
Disable_Interrupts;
info = XQueryFont (p->dpy, XGContextFromGC (p->gc));
Enable_Interrupts;
return Make_Font_Foreign (p->dpy, S48_FALSE, (Font)0, info);
}
static s48_value Internal_List_Fonts (d, pat, with_info) s48_value d, pat; {
char **ret;
int n;
XFontStruct *iret;
register i;
s48_value f, v;
Display *dpy;
S48_DECLARE_GC_PROTECT(2);
Check_Type (d, T_Display);
dpy = DISPLAY(d)->dpy;
Disable_Interrupts;
if (with_info)
ret = XListFontsWithInfo (dpy, Get_Strsym (pat), 65535, &n, &iret);
else
ret = XListFonts (dpy, Get_Strsym (pat), 65535, &n);
Enable_Interrupts;
v = s48_make_vector (n, S48_NULL);
f = S48_NULL;
S48_GC_PROTECT_2 (f, v);
for (i = 0; i < n; i++) {
f = Make_String (ret[i], strlen (ret[i]));
if (with_info)
f = Make_Font (dpy, f, (Font)0, &iret[i]);
S48_VECTOR_SET(v, i, f;)
}
S48_GC_UNPROTECT;
if (with_info)
XFreeFontInfo (ret, (XFontStruct *)0, 0);
else
XFreeFontNames (ret);
return v;
}
static s48_value P_List_Font_Names (d, pat) s48_value d, pat; {
return Internal_List_Fonts (d, pat, 0);
}
static s48_value P_List_Fonts (d, pat) s48_value d, pat; {
return Internal_List_Fonts (d, pat, 1);
}
static s48_value P_Font_Info (f) s48_value f; {
Check_Type (f, T_Font);
FI = *FONT(f)->info;
return Record_To_Vector (Font_Info_Rec, Font_Info_Size,
Sym_Font_Info, FONT(f)->dpy, ~0L);
}
static s48_value P_Char_Info (f, index) s48_value f, index; {
register t = TYPE(index);
register unsigned i;
register XCharStruct *cp;
register XFontStruct *p;
char *msg = "argument must be integer, character, 'min, or 'max";
Check_Type (f, T_Font);
Open_Font_Maybe (f);
p = FONT(f)->info;
cp = &p->max_bounds; cp = &p->max_bounds;
if (t == T_Symbol) { else
if (S48_EQ_P(index, Sym_Min)) cp = &(p->per_char[s48_extract_integer(index)]); // calculated in scheme
cp = &p->min_bounds;
else if (!S48_EQ_P(index, Sym_Max)) v = s48_make_vector(6, S48_FALSE);
Primitive_Error (msg); S48_GC_PROTECT_1(v);
} else { S48_VECTOR_SET(v, 0, s48_enter_integer(cp->lbearing));
if (t == T_Character) S48_VECTOR_SET(v, 1, s48_enter_integer(cp->rbearing));
i = s48_extract_char(index); S48_VECTOR_SET(v, 2, s48_enter_integer(cp->width));
else if (t == T_Fixnum || t == T_Bignum) S48_VECTOR_SET(v, 3, s48_enter_integer(cp->ascent));
i = (unsigned)(int)s48_extract_integer (index); S48_VECTOR_SET(v, 4, s48_enter_integer(cp->descent));
else S48_VECTOR_SET(v, 5, s48_enter_integer(cp->attributes));
Primitive_Error (msg);
if (!p->min_byte1 && !p->max_byte1) { S48_GC_UNPROTECT();
if (i < p->min_char_or_byte2 || i > p->max_char_or_byte2) return v;
Range_Error (index);
i -= p->min_char_or_byte2;
} else {
register unsigned b1 = i & 0xff, b2 = (i >> 8) & 0xff;
if (b1 < p->min_byte1 || b1 > p->max_byte1 ||
b2 < p->min_char_or_byte2 || b2 > p->max_char_or_byte2)
Range_Error (index);
b1 -= p->min_byte1;
b2 -= p->min_char_or_byte2;
i = b1 * (p->max_char_or_byte2 - p->min_char_or_byte2 + 1) + b2;
}
if (p->per_char)
cp = p->per_char + i;
}
CI = *cp;
return Record_To_Vector (Char_Info_Rec, Char_Info_Size,
Sym_Char_Info, FONT(f)->dpy, ~0L);
} }
static s48_value P_Font_Properties (f) s48_value f; { s48_init_font() {
register i, n; S48_EXPORT_FUNCTION(Load_Font);
s48_value v, a, val, x; S48_EXPORT_FUNCTION(Free_Font);
S48_DECLARE_GC_PROTECT(4); S48_EXPORT_FUNCTION(Get_Xfont);
S48_EXPORT_FUNCTION(GContext_Font);
Check_Type (f, T_Font); S48_EXPORT_FUNCTION(Font_Path);
n = FONT(f)->info->n_properties; S48_EXPORT_FUNCTION(Set_Font_Path);
v = s48_make_vector (n, S48_NULL); S48_EXPORT_FUNCTION(Font_Property);
a = val = S48_NULL; S48_EXPORT_FUNCTION(Font_Properties);
S48_GC_PROTECT_4 (v, a, val, f); S48_EXPORT_FUNCTION(List_Fonts);
for (i = 0; i < n; i++) { S48_EXPORT_FUNCTION(List_Font_Names);
register XFontProp *p = FONT(f)->info->properties+i; S48_EXPORT_FUNCTION(Font_Info);
a = Make_Atom (p->name); S48_EXPORT_FUNCTION(Char_Info);
val = s48_enter_integer ((unsigned long)p->card32);
x = s48_cons (a, val);
S48_VECTOR_SET(v, i, x;)
}
S48_GC_UNPROTECT;
return v;
}
static s48_value P_Font_Path (d) s48_value d; {
s48_value v;
int i, n;
char **ret;
S48_DECLARE_GC_PROTECT(1);
Check_Type (d, T_Display);
Disable_Interrupts;
ret = XGetFontPath (DISPLAY(d)->dpy, &n);
Enable_Interrupts;
v = s48_make_vector (n, S48_NULL);
S48_GC_PROTECT_1 (v);
for (i = 0; i < n; i++) {
s48_value x;
x = Make_String (ret[i], strlen (ret[i]));
S48_VECTOR_SET(v, i, x;)
}
S48_GC_UNPROTECT;
XFreeFontPath (ret);
return P_Vector_To_List (v);
}
static s48_value P_Set_Font_Path (d, p) s48_value d, p; {
register char **path;
register i, n;
s48_value c;
Alloca_Begin;
Check_Type (d, T_Display);
Check_List (p);
n = Fast_Length (p);
Alloca (path, char**, n * sizeof (char *));
for (i = 0; i < n; i++, p = S48_CDR (p)) {
c = S48_CAR (p);
Get_Strsym_Stack (c, path[i]);
}
XSetFontPath (DISPLAY(d)->dpy, path, n);
Alloca_End;
return Void;
}
elk_init_xlib_font () {
Define_Symbol (&Sym_Font_Info, "font-info");
Define_Symbol (&Sym_Char_Info, "char-info");
Define_Symbol (&Sym_Min, "min");
Define_Symbol (&Sym_Max, "max");
T_Font = Define_Type (0, "font", NOFUNC, sizeof (struct S_Font),
Font_Equal, Font_Equal, Font_Print, Font_Visit);
Define_Primitive (P_Fontp, "font?", 1, 1, EVAL);
Define_Primitive (P_Font_Display, "font-display", 1, 1, EVAL);
Define_Primitive (P_Open_Font, "open-font", 2, 2, EVAL);
Define_Primitive (P_Close_Font, "close-font", 1, 1, EVAL);
Define_Primitive (P_Font_Name, "font-name", 1, 1, EVAL);
Define_Primitive (P_Gcontext_Font, "gcontext-font", 1, 1, EVAL);
Define_Primitive (P_List_Font_Names, "list-font-names", 2, 2, EVAL);
Define_Primitive (P_List_Fonts, "list-fonts", 2, 2, EVAL);
Define_Primitive (P_Font_Info, "xlib-font-info", 1, 1, EVAL);
Define_Primitive (P_Char_Info, "xlib-char-info", 2, 2, EVAL);
Define_Primitive (P_Font_Properties, "font-properties", 1, 1, EVAL);
Define_Primitive (P_Font_Path, "font-path", 1, 1, EVAL);
Define_Primitive (P_Set_Font_Path, "set-font-path!", 2, 2, EVAL);
} }