scx/c/xlib/font.c

#include "xlib.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;
}

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);
}

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;
}

/* 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++) {
	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;
    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++) {
	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);
}