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