## font-imp.pkg
#
# The font imp is responsible for mapping
# font names to fonts.
#
# If two different threads open the same font
# they will be able to share the representation.
#
# Eventually, we will do some kind
# of finalization of fonts. XXX BUGGO FIXME
# Compiled by:
# src/lib/x-kit/xclient/xclient-internals.sublib### "Mathematics is the Queen of the Sciences and
### number theory is the queen of mathematics."
###
### -- Carl Friedrich Gauss
stipulate
include threadkit; # threadkit is from src/lib/src/lib/thread-kit/src/core-thread-kit/threadkit.pkg #
package vec = rw_vector; # rw_vector is from src/lib/std/src/rw-vector.pkg package dy = display; # display is from src/lib/x-kit/xclient/src/wire/display.pkg package fb = font_base; # font_base is from src/lib/x-kit/xclient/src/window/font-base.pkg package t2s = xtype_to_string; # xtype_to_string is from src/lib/x-kit/xclient/src/to-string/xtype-to-string.pkg package e2s = xerror_to_string; # xerror_to_string is from src/lib/x-kit/xclient/src/to-string/xerror-to-string.pkg package xok = xsocket; # xsocket is from src/lib/x-kit/xclient/src/wire/xsocket.pkg package xt = xtypes; # xtypes is from src/lib/x-kit/xclient/src/wire/xtypes.pkg package hs = hash_string; # hash_string is from src/lib/src/hash-string.pkg package v2w = value_to_wire; # value_to_wire is from src/lib/x-kit/xclient/src/wire/value-to-wire.pkg package w2v = wire_to_value; # wire_to_value is from src/lib/x-kit/xclient/src/wire/wire-to-value.pkgherein
package font_imp
: (weak) Font_Imp # Font_Imp is from src/lib/x-kit/xclient/src/window/font-imp.api {
exception FONT_NOT_FOUND;
xid_to_string = t2s::xid_to_string;
# typelocked_hashtable_g is from src/lib/src/typelocked-hashtable-g.pkg # hashtables on font names:
#
package sht
=
typelocked_hashtable_g (
Hash_Key = String;
fun hash_value s
=
hs::hash_string s;
fun same_key (s1: String, s2: String)
=
s1 == s2;
);
Plea_Mail
= OPEN_FONT String
also
Reply_Mail
= SUCCESS fb::Font
| FAILURE
;
Font_Imp
=
FONT_IMP
{ plea_slot: Mailslot( Plea_Mail ),
reply_slot: Mailslot( Reply_Mail )
};
fun make_font_imp (xdpy as dy::XDISPLAY { xsocket, next_xid, ... })
=
{ send_xrequest_and_verify_success
=
xok::send_xrequest_and_verify_success
#
xsocket;
query_font = xok::query_font xsocket;
plea_slot = make_mailslot ();
reply_slot = make_mailslot ();
font_map = sht::make_hashtable { size_hint => 32, not_found_exception => FAIL "FontMap" };
insert = sht::set font_map;
find = sht::find font_map;
fun make_font id
=
{ (query_font { font => id })
->
{ min_bounds, max_bounds,
min_char, max_char,
default_char,
draw_dir,
all_chars_exist,
max_byte1,
font_ascent,
font_descent,
properties,
char_infos, ...
};
fun in_range c
=
c >= min_char and
c <= max_char;
char_info
=
case char_infos
#
[] => if (in_range default_char)
#
fn _ = min_bounds;
else
fn c = in_range c ?? min_bounds
:: (raise exception fb::NO_CHAR_INFO);
fi;
#
l => {
table = vec::from_list l;
fun info_exists (xt::CHAR_INFO { char_width=>0, left_bearing=>0, right_bearing=>0, ... } )
=>
FALSE;
info_exists _
=>
TRUE;
end;
fun lookup c
=
if (in_range c)
case (vec::get (table, c - min_char))
#
xt::CHAR_INFO { char_width=>0, left_bearing=>0, right_bearing=>0, ... }
=>
NULL;
per_compile_info
=>
THE per_compile_info;
esac;
else
NULL;
fi;
fun get_info default c
=
if (in_range c)
#
case (lookup c)
#
THE c => c;
NULL => default ();
esac;
else
default ();
fi;
case (lookup default_char)
#
NULL => get_info (fn () = raise exception fb::NO_CHAR_INFO);
THE c => get_info (fn () = c);
esac;
};
esac;
info = if (max_byte1 == 0)
fb::FINFO8
{
min_bounds,
max_bounds,
min_char,
max_char,
default_char,
draw_dir,
all_chars_exist,
font_ascent,
font_descent,
properties,
char_info
};
else
xgripe::impossible "[mkFont: 16-bit font]";
fi;
fb::FONT { id, xdpy, info };
};
fun open_a_font name
=
font
where
new_id = next_xid ();
xlogger::log_if xlogger::font_logging 0
.{ "open_a_font " + name + ", id = " + xid_to_string new_id; };
block_until_mailop_fires
(send_xrequest_and_verify_success
(v2w::encode_open_font { font => new_id, name } ));
xlogger::log_if xlogger::font_logging 0
.{ "open_a_font: open succeeded."; };
font = make_font new_id;
insert (name, font);
end;
fun get_font name
=
case (find name)
#
THE font => SUCCESS font;
NULL => SUCCESS (open_a_font name)
except
_ = FAILURE;
esac;
fun loop ()
=
{ (take_from_mailslot plea_slot)
->
(OPEN_FONT font_name);
put_in_mailslot (reply_slot, get_font font_name);
loop ();
};
xlogger::make_thread "font_imp" loop;
FONT_IMP { plea_slot, reply_slot };
}; # fun make_font_imp
fun do_req req (FONT_IMP { plea_slot, reply_slot } ) arg
=
{ put_in_mailslot (plea_slot, req arg);
#
case (take_from_mailslot reply_slot)
#
SUCCESS f => f;
FAILURE => raise exception FONT_NOT_FOUND;
esac;
};
open_a_font = do_req OPEN_FONT;
}; # package font_imp
end;