diff --git a/c/xlib/font.c b/c/xlib/font.c index db66706..ad8c79e 100644 --- a/c/xlib/font.c +++ b/c/xlib/font.c @@ -1,299 +1,194 @@ #include "xlib.h" +#include "scheme48.h" -s48_value Sym_Char_Info; -static s48_value Sym_Font_Info, Sym_Min, Sym_Max; -Generic_Predicate (Font) - -static Font_Equal (x, y) s48_value x, y; { - Font id1 = FONT(x)->id, id2 = FONT(y)->id; - if (id1 && id2) - return id1 == id2 && FONT(x)->dpy == FONT(y)->dpy; - else - return 0; +s48_value Load_Font(s48_value Xdisplay, s48_value font_name) { + return ENTER_FONTSTRUCT(XLoadQueryFont(EXTRACT_DISPLAY(Xdisplay), + s48_extract_string(font_name))); } -Generic_Print (Font, "#[font %lu]", FONT(x)->id ? FONT(x)->id : POINTER(x)) - -static Font_Visit (fp, f) s48_value *fp; int (*f)(); { - (*f)(&FONT(*fp)->name); +s48_value Free_Font(s48_value Xdisplay, s48_value Xfontstruct) { + XFreeFont(EXTRACT_DISPLAY(Xdisplay), + EXTRACT_FONTSTRUCT(Xfontstruct)); + return S48_UNSPECIFIC; } -Generic_Get_Display (Font, FONT) - -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; +s48_value Get_Xfont(s48_value Xfontstruct) { + return ENTER_FONT((EXTRACT_FONTSTRUCT(Xfontstruct))->fid); } -/* 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 GContext_Font(s48_value Xdisplay, s48_value Xgcontext) { + GContext gc = XGContextFromGC(EXTRACT_GCONTEXT(Xgcontext)); + Display* dpy = EXTRACT_DISPLAY(Xdisplay); + return ENTER_FONTSTRUCT(XQueryFont(dpy, gc)); } -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); +s48_value Font_Path(s48_value Xdisplay) { + int n, i; + 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; { - Check_Type (f, T_Font); - Open_Font_Maybe (f); - return FONT(f)->id; +s48_value Set_Font_Path(s48_value Xdisplay, s48_value path) { + int i, n = S48_VECTOR_LENGTH(path); + char* sa[n]; + + 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; { - register char *s; - XFontStruct *p; - Alloca_Begin; +s48_value List_Fonts(s48_value Xdisplay, s48_value pattern) { + char** sa; + XFontStruct* fsa; + int i,n; + s48_value v; + S48_DECLARE_GC_PROTECT(1); - 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; + XListFontsWithInfo(EXTRACT_DISPLAY(Xdisplay), + s48_extract_string(pattern), + 65535, + &n, + &fsa); + + 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; { - XFontStruct *p; +s48_value Font_Properties(s48_value Xfontstruct) { + s48_value v; + int i,n; + XFontStruct* fs = EXTRACT_FONTSTRUCT(Xfontstruct); + XFontProp* p; + S48_DECLARE_GC_PROTECT(1); - Check_Type (d, T_Display) - p = Internal_Open_Font (DISPLAY(d)->dpy, name); - return Make_Font (DISPLAY(d)->dpy, name, p->fid, p); + n = fs->n_properties; + v = s48_make_vector(n, S48_FALSE); + 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 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 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 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; +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 P_Font_Name (f) s48_value f; { - Check_Type (f, T_Font); - return FONT(f)->name; -} +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); -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++) { - 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; + if (S48_FALSE_P(index)) + cp = &p->min_bounds; + else if (S48_TRUE_P(index)) 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); + 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; } -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++) { - register XFontProp *p = FONT(f)->info->properties+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; - 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); +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); }