Mercurial > hg > xemacs-beta
view lisp/msw-faces.el @ 4952:19a72041c5ed
Mule-izing, various fixes related to char * arguments
-------------------- ChangeLog entries follow: --------------------
modules/ChangeLog addition:
2010-01-26 Ben Wing <ben@xemacs.org>
* postgresql/postgresql.c:
* postgresql/postgresql.c (CHECK_LIVE_CONNECTION):
* postgresql/postgresql.c (print_pgresult):
* postgresql/postgresql.c (Fpq_conn_defaults):
* postgresql/postgresql.c (Fpq_connectdb):
* postgresql/postgresql.c (Fpq_connect_start):
* postgresql/postgresql.c (Fpq_result_status):
* postgresql/postgresql.c (Fpq_res_status):
Mule-ize large parts of it.
2010-01-26 Ben Wing <ben@xemacs.org>
* ldap/eldap.c (print_ldap):
* ldap/eldap.c (allocate_ldap):
Use write_ascstring().
src/ChangeLog addition:
2010-01-26 Ben Wing <ben@xemacs.org>
* alloc.c:
* alloc.c (build_ascstring):
* alloc.c (build_msg_cistring):
* alloc.c (staticpro_1):
* alloc.c (staticpro_name):
* alloc.c (staticpro_nodump_1):
* alloc.c (staticpro_nodump_name):
* alloc.c (unstaticpro_nodump_1):
* alloc.c (mcpro_1):
* alloc.c (mcpro_name):
* alloc.c (object_memory_usage_stats):
* alloc.c (common_init_alloc_early):
* alloc.c (init_alloc_once_early):
* buffer.c (print_buffer):
* buffer.c (vars_of_buffer):
* buffer.c (common_init_complex_vars_of_buffer):
* buffer.c (init_initial_directory):
* bytecode.c (invalid_byte_code):
* bytecode.c (print_compiled_function):
* bytecode.c (mark_compiled_function):
* chartab.c (print_table_entry):
* chartab.c (print_char_table):
* config.h.in:
* console-gtk.c:
* console-gtk.c (gtk_device_to_console_connection):
* console-gtk.c (gtk_semi_canonicalize_console_connection):
* console-gtk.c (gtk_canonicalize_console_connection):
* console-gtk.c (gtk_semi_canonicalize_device_connection):
* console-gtk.c (gtk_canonicalize_device_connection):
* console-stream.c (stream_init_frame_1):
* console-stream.c (vars_of_console_stream):
* console-stream.c (init_console_stream):
* console-x.c (x_semi_canonicalize_console_connection):
* console-x.c (x_semi_canonicalize_device_connection):
* console-x.c (x_canonicalize_device_connection):
* console-x.h:
* data.c (eq_with_ebola_notice):
* data.c (Fsubr_interactive):
* data.c (Fnumber_to_string):
* data.c (digit_to_number):
* device-gtk.c (gtk_init_device):
* device-msw.c (print_devmode):
* device-x.c (x_event_name):
* dialog-msw.c (handle_directory_dialog_box):
* dialog-msw.c (handle_file_dialog_box):
* dialog-msw.c (vars_of_dialog_mswindows):
* doc.c (weird_doc):
* doc.c (Fsnarf_documentation):
* doc.c (vars_of_doc):
* dumper.c (pdump):
* dynarr.c:
* dynarr.c (Dynarr_realloc):
* editfns.c (Fuser_real_login_name):
* editfns.c (get_home_directory):
* elhash.c (print_hash_table_data):
* elhash.c (print_hash_table):
* emacs.c (main_1):
* emacs.c (vars_of_emacs):
* emodules.c:
* emodules.c (_emodules_list):
* emodules.c (Fload_module):
* emodules.c (Funload_module):
* emodules.c (Flist_modules):
* emodules.c (find_make_module):
* emodules.c (attempt_module_delete):
* emodules.c (emodules_load):
* emodules.c (emodules_doc_subr):
* emodules.c (emodules_doc_sym):
* emodules.c (syms_of_module):
* emodules.c (vars_of_module):
* emodules.h:
* eval.c (print_subr):
* eval.c (signal_call_debugger):
* eval.c (build_error_data):
* eval.c (signal_error):
* eval.c (maybe_signal_error):
* eval.c (signal_continuable_error):
* eval.c (maybe_signal_continuable_error):
* eval.c (signal_error_2):
* eval.c (maybe_signal_error_2):
* eval.c (signal_continuable_error_2):
* eval.c (maybe_signal_continuable_error_2):
* eval.c (signal_ferror):
* eval.c (maybe_signal_ferror):
* eval.c (signal_continuable_ferror):
* eval.c (maybe_signal_continuable_ferror):
* eval.c (signal_ferror_with_frob):
* eval.c (maybe_signal_ferror_with_frob):
* eval.c (signal_continuable_ferror_with_frob):
* eval.c (maybe_signal_continuable_ferror_with_frob):
* eval.c (syntax_error):
* eval.c (syntax_error_2):
* eval.c (maybe_syntax_error):
* eval.c (sferror):
* eval.c (sferror_2):
* eval.c (maybe_sferror):
* eval.c (invalid_argument):
* eval.c (invalid_argument_2):
* eval.c (maybe_invalid_argument):
* eval.c (invalid_constant):
* eval.c (invalid_constant_2):
* eval.c (maybe_invalid_constant):
* eval.c (invalid_operation):
* eval.c (invalid_operation_2):
* eval.c (maybe_invalid_operation):
* eval.c (invalid_change):
* eval.c (invalid_change_2):
* eval.c (maybe_invalid_change):
* eval.c (invalid_state):
* eval.c (invalid_state_2):
* eval.c (maybe_invalid_state):
* eval.c (wtaerror):
* eval.c (stack_overflow):
* eval.c (out_of_memory):
* eval.c (print_multiple_value):
* eval.c (issue_call_trapping_problems_warning):
* eval.c (backtrace_specials):
* eval.c (backtrace_unevalled_args):
* eval.c (Fbacktrace):
* eval.c (warn_when_safe):
* event-Xt.c (modwarn):
* event-Xt.c (modbarf):
* event-Xt.c (check_modifier):
* event-Xt.c (store_modifier):
* event-Xt.c (emacs_Xt_format_magic_event):
* event-Xt.c (describe_event):
* event-gtk.c (dragndrop_data_received):
* event-gtk.c (store_modifier):
* event-gtk.c (gtk_reset_modifier_mapping):
* event-msw.c (dde_eval_string):
* event-msw.c (Fdde_alloc_advise_item):
* event-msw.c (mswindows_dde_callback):
* event-msw.c (FROB):
* event-msw.c (emacs_mswindows_format_magic_event):
* event-stream.c (external_debugging_print_event):
* event-stream.c (execute_help_form):
* event-stream.c (vars_of_event_stream):
* events.c (print_event_1):
* events.c (print_event):
* events.c (event_equal):
* extents.c (print_extent_1):
* extents.c (print_extent):
* extents.c (vars_of_extents):
* faces.c (print_face):
* faces.c (complex_vars_of_faces):
* file-coding.c:
* file-coding.c (print_coding_system):
* file-coding.c (print_coding_system_in_print_method):
* file-coding.c (default_query_method):
* file-coding.c (find_coding_system):
* file-coding.c (make_coding_system_1):
* file-coding.c (chain_print):
* file-coding.c (undecided_print):
* file-coding.c (gzip_print):
* file-coding.c (vars_of_file_coding):
* file-coding.c (complex_vars_of_file_coding):
* fileio.c:
* fileio.c (report_file_type_error):
* fileio.c (report_error_with_errno):
* fileio.c (report_file_error):
* fileio.c (barf_or_query_if_file_exists):
* fileio.c (vars_of_fileio):
* floatfns.c (matherr):
* fns.c (print_bit_vector):
* fns.c (Fmapconcat):
* fns.c (add_suffix_to_symbol):
* fns.c (add_prefix_to_symbol):
* frame-gtk.c:
* frame-gtk.c (Fgtk_window_id):
* frame-x.c (def):
* frame-x.c (x_cde_transfer_callback):
* frame.c:
* frame.c (Fmake_frame):
* gc.c (show_gc_cursor_and_message):
* gc.c (vars_of_gc):
* glyphs-eimage.c (png_instantiate):
* glyphs-eimage.c (tiff_instantiate):
* glyphs-gtk.c (gtk_print_image_instance):
* glyphs-msw.c (mswindows_print_image_instance):
* glyphs-x.c (x_print_image_instance):
* glyphs-x.c (update_widget_face):
* glyphs.c (make_string_from_file):
* glyphs.c (print_image_instance):
* glyphs.c (signal_image_error):
* glyphs.c (signal_image_error_2):
* glyphs.c (signal_double_image_error):
* glyphs.c (signal_double_image_error_2):
* glyphs.c (xbm_mask_file_munging):
* glyphs.c (pixmap_to_lisp_data):
* glyphs.h:
* gui.c (gui_item_display_flush_left):
* hpplay.c (player_error_internal):
* hpplay.c (myHandler):
* intl-win32.c:
* intl-win32.c (langcode_to_lang):
* intl-win32.c (sublangcode_to_lang):
* intl-win32.c (Fmswindows_get_locale_info):
* intl-win32.c (lcid_to_locale_mule_or_no):
* intl-win32.c (mswindows_multibyte_to_unicode_print):
* intl-win32.c (complex_vars_of_intl_win32):
* keymap.c:
* keymap.c (print_keymap):
* keymap.c (ensure_meta_prefix_char_keymapp):
* keymap.c (Fkey_description):
* keymap.c (Ftext_char_description):
* lisp.h:
* lisp.h (struct):
* lisp.h (DECLARE_INLINE_HEADER):
* lread.c (Fload_internal):
* lread.c (locate_file):
* lread.c (read_escape):
* lread.c (read_raw_string):
* lread.c (read1):
* lread.c (read_list):
* lread.c (read_compiled_function):
* lread.c (init_lread):
* lrecord.h:
* marker.c (print_marker):
* marker.c (marker_equal):
* menubar-msw.c (displayable_menu_item):
* menubar-x.c (command_builder_operate_menu_accelerator):
* menubar.c (vars_of_menubar):
* minibuf.c (reinit_complex_vars_of_minibuf):
* minibuf.c (complex_vars_of_minibuf):
* mule-charset.c (Fmake_charset):
* mule-charset.c (complex_vars_of_mule_charset):
* mule-coding.c (iso2022_print):
* mule-coding.c (fixed_width_query):
* number.c (bignum_print):
* number.c (ratio_print):
* number.c (bigfloat_print):
* number.c (bigfloat_finalize):
* objects-msw.c:
* objects-msw.c (mswindows_color_to_string):
* objects-msw.c (mswindows_color_list):
* objects-tty.c:
* objects-tty.c (tty_font_list):
* objects-tty.c (tty_find_charset_font):
* objects-xlike-inc.c (xft_find_charset_font):
* objects-xlike-inc.c (endif):
* print.c:
* print.c (write_istring):
* print.c (write_ascstring):
* print.c (Fterpri):
* print.c (Fprint):
* print.c (print_error_message):
* print.c (print_vector_internal):
* print.c (print_cons):
* print.c (print_string):
* print.c (printing_unreadable_object):
* print.c (print_internal):
* print.c (print_float):
* print.c (print_symbol):
* process-nt.c (mswindows_report_winsock_error):
* process-nt.c (nt_canonicalize_host_name):
* process-unix.c (unix_canonicalize_host_name):
* process.c (print_process):
* process.c (report_process_error):
* process.c (report_network_error):
* process.c (make_process_internal):
* process.c (Fstart_process_internal):
* process.c (status_message):
* process.c (putenv_internal):
* process.c (vars_of_process):
* process.h:
* profile.c (vars_of_profile):
* rangetab.c (print_range_table):
* realpath.c (vars_of_realpath):
* redisplay.c (vars_of_redisplay):
* search.c (wordify):
* search.c (Freplace_match):
* sheap.c (sheap_adjust_h):
* sound.c (report_sound_error):
* sound.c (Fplay_sound_file):
* specifier.c (print_specifier):
* symbols.c (Fsubr_name):
* symbols.c (do_symval_forwarding):
* symbols.c (set_default_buffer_slot_variable):
* symbols.c (set_default_console_slot_variable):
* symbols.c (store_symval_forwarding):
* symbols.c (default_value):
* symbols.c (defsymbol_massage_name_1):
* symbols.c (defsymbol_massage_name_nodump):
* symbols.c (defsymbol_massage_name):
* symbols.c (defsymbol_massage_multiword_predicate_nodump):
* symbols.c (defsymbol_massage_multiword_predicate):
* symbols.c (defsymbol_nodump):
* symbols.c (defsymbol):
* symbols.c (defkeyword):
* symbols.c (defkeyword_massage_name):
* symbols.c (check_module_subr):
* symbols.c (deferror_1):
* symbols.c (deferror):
* symbols.c (deferror_massage_name):
* symbols.c (deferror_massage_name_and_message):
* symbols.c (defvar_magic):
* symeval.h:
* symeval.h (DEFVAR_SYMVAL_FWD):
* sysdep.c:
* sysdep.c (init_system_name):
* sysdll.c:
* sysdll.c (MAYBE_PREPEND_UNDERSCORE):
* sysdll.c (dll_function):
* sysdll.c (dll_variable):
* sysdll.c (dll_error):
* sysdll.c (dll_open):
* sysdll.c (dll_close):
* sysdll.c (image_for_address):
* sysdll.c (my_find_image):
* sysdll.c (search_linked_libs):
* sysdll.h:
* sysfile.h:
* sysfile.h (DEFAULT_DIRECTORY_FALLBACK):
* syswindows.h:
* tests.c (DFC_CHECK_LENGTH):
* tests.c (DFC_CHECK_CONTENT):
* tests.c (Ftest_hash_tables):
* text.c (vars_of_text):
* text.h:
* tooltalk.c (tt_opnum_string):
* tooltalk.c (tt_message_arg_ival_string):
* tooltalk.c (Ftooltalk_default_procid):
* tooltalk.c (Ftooltalk_default_session):
* tooltalk.c (init_tooltalk):
* tooltalk.c (vars_of_tooltalk):
* ui-gtk.c (Fdll_load):
* ui-gtk.c (type_to_marshaller_type):
* ui-gtk.c (Fgtk_import_function_internal):
* ui-gtk.c (emacs_gtk_object_printer):
* ui-gtk.c (emacs_gtk_boxed_printer):
* unicode.c (unicode_to_ichar):
* unicode.c (unicode_print):
* unicode.c (unicode_query):
* unicode.c (vars_of_unicode):
* unicode.c (complex_vars_of_unicode):
* win32.c:
* win32.c (mswindows_report_process_error):
* window.c (print_window):
* xemacs.def.in.in:
BASIC IDEA: Further fixing up uses of char * and CIbyte *
to reflect their actual semantics; Mule-izing some code;
redoing of the not-yet-working code to handle message translation.
Clean up code to handle message-translation (not yet working).
Create separate versions of build_msg_string() for working with
Ibyte *, CIbyte *, and Ascbyte * arguments. Assert that Ascbyte *
arguments are pure-ASCII. Make build_msg_string() be the same
as build_msg_ascstring(). Create same three versions of GETTEXT()
and DEFER_GETTEXT(). Also create build_defer_string() and
variants for the equivalent of DEFER_GETTEXT() when building a
string. Remove old CGETTEXT(). Clean up code where GETTEXT(),
DEFER_GETTEXT(), build_msg_string(), etc. was being called and
introduce some new calls to build_msg_string(), etc. Remove
GETTEXT() from calls to weird_doc() -- we assume that the
message snarfer knows about weird_doc(). Remove uses of
DEFER_GETTEXT() from error messages in sysdep.c and instead use
special comments /* @@@begin-snarf@@@ */ and /* @@@end-snarf@@@ */
that the message snarfer presumably knows about.
Create build_ascstring() and use it in many instances in place
of build_string(). The purpose of having Ascbyte * variants is
to make the code more self-documenting in terms of what sort of
semantics is expected for char * strings. In fact in the process
of looking for uses of build_string(), much improperly Mule-ized
was discovered.
Mule-ize a lot of code as described in previous paragraph,
e.g. in sysdep.c.
Make the error functions take Ascbyte * strings and fix up a
couple of places where non-pure-ASCII strings were being passed in
(file-coding.c, mule-coding.c, unicode.c). (It's debatable whether
we really need to make the error functions work this way. It
helps catch places where code is written in a way that message
translation won't work, but we may well never implement message
translation.)
Make staticpro() and friends take Ascbyte * strings instead of
raw char * strings. Create a const_Ascbyte_ptr dynarr type
to describe what's held by staticpro_names[] and friends,
create pdump descriptions for const_Ascbyte_ptr dynarrs, and
use them in place of specially-crafted staticpro descriptions.
Mule-ize certain other functions (e.g. x_event_name) by correcting
raw use of char * to Ascbyte *, Rawbyte * or another such type,
and raw use of char[] buffers to another type (usually Ascbyte[]).
Change many uses of write_c_string() to write_msg_string(),
write_ascstring(), etc.
Mule-ize emodules.c, emodules.h, sysdll.h.
Fix some un-Mule-ized code in intl-win32.c.
A comment in event-Xt.c and the limitations of the message
snarfer (make-msgfile or whatever) is presumably incorrect --
it should be smart enough to handle function calls spread over
more than one line. Clean up code in event-Xt.c that was
written awkwardly for this reason.
In config.h.in, instead of NEED_ERROR_CHECK_TYPES_INLINES,
create a more general XEMACS_DEFS_NEEDS_INLINE_DECLS to
indicate when inlined functions need to be declared in
xemacs.defs.in.in, and make use of it in xemacs.defs.in.in.
We need to do this because postgresql.c now calls qxestrdup(),
which is an inline function.
Make nconc2() and other such functions MODULE_API and put
them in xemacs.defs.in.in since postgresql.c now uses them.
Clean up indentation in lread.c and a few other places.
In text.h, document ASSERT_ASCTEXT_ASCII() and
ASSERT_ASCTEXT_ASCII_LEN(), group together the stand-in
encodings and add some more for DLL symbols, function and
variable names, etc.
| author | Ben Wing <ben@xemacs.org> |
|---|---|
| date | Tue, 26 Jan 2010 23:22:30 -0600 |
| parents | 58cd1008908c |
| children | 668c73e222fd |
line wrap: on
line source
;;; msw-faces.el --- mswindows-specific face stuff. ;;; Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc. ;;; Copyright (C) 1995, 1996, 2002 Ben Wing. ;; Author: Jamie Zawinski ;; Modified by: Chuck Thompson ;; Modified by: Ben Wing ;; Modified by: Martin Buchholz ;; Rewritten for mswindows by: Jonathan Harris ;; This file is part of XEmacs. ;; XEmacs is free software; you can redistribute it and/or modify it ;; under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; XEmacs is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with XEmacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. ;; This file does the magic to parse mswindows font names, and make sure that ;; the default and modeline attributes of new frames are specified enough. (globally-declare-boundp '(mswindows-font-regexp mswindows-font-regexp-missing-1 mswindows-font-regexp-missing-2 mswindows-font-regexp-missing-3 mswindows-font-regexp-missing-4)) (defun mswindows-init-global-faces () (set-face-font 'gui-element "MS Sans Serif:Regular:8" nil 'mswindows)) (defun mswindows-init-device-faces (device) (let ((color-default (device-system-metric device 'color-default)) (color-3d-face (device-system-metric device 'color-3d-face))) ; Force creation of the default face font so that if it fails we get ; an error now instead of a crash at frame creation. (unless (face-font-instance 'default device) (error "Can't find a suitable default font")) ;; Don't set them on the device because then the global setting won't ;; override them. ;; #### Use device tags if we have multiple msprinter devices. (can we?) (if (car color-default) (set-face-foreground 'default (car color-default) nil (device-type device))) (if (cdr color-default) (set-face-background 'default (cdr color-default) nil (device-type device))) (if (car color-3d-face) (set-face-foreground 'gui-element (car color-3d-face) nil (device-type device))) (if (cdr color-3d-face) (set-face-background 'gui-element (cdr color-3d-face) nil (device-type device))) )) (defun mswindows-init-frame-faces (frame) ) ;; Other functions expect these regexps (let ((- ":") ;; What happens if a font family contains a colon? I can't find any ;; documentation on that, and don't have a font editor to hand to test. (fontname "\\([^:]*\\)") ; 1 (style "\\(\\(?:[a-zA-Z]+\\(?: +[a-zA-Z]+\\)*\\)?\\)") ; 2 (pointsize "\\([0-9]*\\)") ; 3 (effects "\\(\\(?:[a-zA-Z]+\\(?: +[a-zA-Z]+\\)*\\)?\\)") ; 4 ;; must match "OEM/DOS" (charset "\\([a-zA-Z/ ]*\\)") ; 5 ) (defconst mswindows-font-regexp (concat "^" fontname - style - pointsize - effects - charset "$")) (defconst mswindows-font-regexp-missing-1 (concat "^" fontname - style - pointsize - effects "$")) (defconst mswindows-font-regexp-missing-2 (concat "^" fontname - style - pointsize "$")) (defconst mswindows-font-regexp-missing-3 (concat "^" fontname - style "$")) (defconst mswindows-font-regexp-missing-4 (concat "^" fontname "$")) ) ;;; Fill in missing parts of a font spec. This is primarily intended as a ;;; helper function for the functions below. ;;; mswindows fonts look like: ;;; fontname[:[weight][ slant][:pointsize[:effects]]][:charset] ;;; A minimal mswindows font spec looks like: ;;; Courier New ;;; A maximal mswindows font spec looks like: ;;; Courier New:Bold Italic:10:underline strikeout:Western (defun mswindows-canonicalize-font-name (font) "Given a mswindows font or font name, return its name in canonical form. This adds missing colons and fills in the style field with \"Regular\". This does *NOT* fill in the point size or charset fields, because in those cases an empty field is not equivalent to any particular field value, but a wildcard allowing for any possible value (charset Western and point size 10 are chosen first, if they exist)." (if (font-instance-p font) (setq font (font-instance-name font))) ;; fill in missing colons (setq font (cond ((string-match mswindows-font-regexp font) font) ((string-match mswindows-font-regexp-missing-1 font) (concat font ":")) ((string-match mswindows-font-regexp-missing-2 font) (concat font "::")) ((string-match mswindows-font-regexp-missing-3 font) (concat font ":::")) ((string-match mswindows-font-regexp-missing-4 font) (concat font "::::")) (t "::::"))) (or (string-match mswindows-font-regexp font) (error "can't parse %S" font)) (if (equal "" (match-string 2 font)) (concat (substring font 0 (match-beginning 2)) "Regular" (substring font (match-beginning 2))) font)) (defun mswindows-parse-font-style (style) ;; Parse a style into a cons (WEIGHT . SLANT). WEIGHT will never be the ;; empty string (it may be "Regular"), but SLANT will be empty for ;; non-italic. (save-match-data (let ((case-fold-search t)) (cond ((equalp style "Italic") '("Regular" . "Italic")) ((string-match "^\\([a-zA-Z ]+?\\) +Italic$" style) (cons (match-string 1 style) "Italic")) (t (cons style "")))))) (defun mswindows-construct-font-style (weight slant) ;; Construct the style from WEIGHT and SLANT. Opposite of ;; mswindows-parse-font-style. (cond ((and (equal slant "") (equal weight "")) "Regular") ((equal slant "") weight) ((or (equalp weight "Regular") (equal weight "")) slant) (t (concat weight " " slant)))) (defun mswindows-frob-font-style (font which) ;; Given a font name or font instance, return a name with the style field ;; (which includes weight and/or slant) changed according to WHICH, a plist. ;; If no entry found, don't change. (if (null font) nil (setq font (mswindows-canonicalize-font-name font)) (or (string-match mswindows-font-regexp font) (error "can't parse %S" font)) (let* ((style (match-string 2 font)) (style-rep (save-match-data (or (loop for (x y) on which by #'cddr if (string-match (concat "^" x "$") style) return (replace-match y nil nil style)) style)))) (concat (substring font 0 (match-beginning 2)) style-rep (substring font (match-end 2)))))) (defun mswindows-frob-font-style-and-sizify (font which &optional device) (if (null font) nil (let* ((oldwidth (if (font-instance-p font) (font-instance-width font) (let ((fi (make-font-instance font device t))) (and fi (font-instance-width fi))))) (newname (mswindows-frob-font-style font which)) (newfont (make-font-instance newname device t))) ;; Hack! On MS Windows, bold fonts (even monospaced) are often wider ;; than the equivalent non-bold font. Making the bold font one point ;; smaller usually makes it the same width (maybe at the expense of ;; making it one pixel shorter). Do the same trick in both directions. (when (font-instance-p newfont) (let ((newerfont newfont)) (block nil (while (and newerfont oldwidth) (setq newfont newerfont) (cond ((< (font-instance-width newfont) oldwidth) (setq newerfont (make-font-instance (mswindows-find-larger-font newfont device) device t)) (if (and newerfont (> (font-instance-width newerfont) oldwidth)) (return nil))) ((> (font-instance-width newfont) oldwidth) (setq newerfont (make-font-instance (mswindows-find-smaller-font newfont device) device t)) (if (and newerfont (< (font-instance-width newerfont) oldwidth)) (return nil))) (t (return nil)))))) (if (font-instance-p newfont) (font-instance-name newfont) newfont))))) (defconst mswindows-nonbold-weight-regexp ;; He looked so, so cool with the ultra light dangling from his mouth as ;; his fingers spun out demisemiquavers from the keyboard ... "\\(Regular\\|Thin\\|Extra Light\\|Ultra Light\\|Light\\|Normal\\|Medium\\|Semi Bold\\|Demi Bold\\)" ) (defconst mswindows-bold-weight-regexp "\\(Semi Bold\\|Demi Bold\\|Bold\\|Extra Bold\\|Ultra Bold\\|Heavy\\|Black\\)" ) (defconst mswindows-make-font-bold-mapper `(,mswindows-nonbold-weight-regexp "Bold" "Italic" "Bold Italic" ,(concat mswindows-nonbold-weight-regexp " Italic") "Bold Italic")) (defconst mswindows-make-font-nonbold-mapper `(,mswindows-bold-weight-regexp "Regular" ,(concat mswindows-bold-weight-regexp " Italic") "Italic")) (defconst mswindows-make-font-italic-mapper '("\\(.*\\)Italic" "\\1Italic" "\\(.*\\)" "\\1 Italic")) (defconst mswindows-make-font-unitalic-mapper '("Italic" "Regular" "\\(.*\\) Italic" "\\1")) (defconst mswindows-make-font-bold-italic-mapper `(,mswindows-nonbold-weight-regexp "Bold Italic" ,(concat mswindows-nonbold-weight-regexp " Italic") "Bold Italic" "Italic" "Bold Italic" ,mswindows-bold-weight-regexp "\\1 Italic")) (defun mswindows-make-font-bold (font &optional device) "Given a mswindows font specification, this attempts to make a bold font. If it fails, it returns nil." (mswindows-frob-font-style-and-sizify font mswindows-make-font-bold-mapper device)) (defun mswindows-make-font-unbold (font &optional device) "Given a mswindows font specification, this attempts to make a non-bold font. If it fails, it returns nil." (mswindows-frob-font-style-and-sizify font mswindows-make-font-nonbold-mapper device)) (defun mswindows-make-font-italic (font &optional device) "Given a mswindows font specification, this attempts to make an `italic' font. If it fails, it returns nil." (try-font-name (mswindows-frob-font-style font mswindows-make-font-italic-mapper) device)) (defun mswindows-make-font-unitalic (font &optional device) "Given a mswindows font specification, this attempts to make a non-italic font. If it fails, it returns nil." (try-font-name (mswindows-frob-font-style font mswindows-make-font-unitalic-mapper) device)) (defun mswindows-make-font-bold-italic (font &optional device) "Given a mswindows font specification, this attempts to make a `bold-italic' font. If it fails, it returns nil." (mswindows-frob-font-style-and-sizify font mswindows-make-font-bold-italic-mapper device)) (defun mswindows-available-font-sizes (font device) (if (font-instance-p font) (setq font (font-instance-name font))) (setq font (mswindows-canonicalize-font-name font)) (or (string-match mswindows-font-regexp font) (error "Can't parse %S" font)) ;; turn pointsize into wildcard (setq font (concat (substring font 0 (match-beginning 3)) (substring font (match-end 3) (match-end 0)))) (sort (delq nil (mapcar #'(lambda (name) (and (string-match mswindows-font-regexp name) (string-to-int (substring name (match-beginning 3) (match-end 3))))) (font-list font device))) #'<)) (defun mswindows-frob-font-size (font up-p device) (if (stringp font) (setq font (make-font-instance font device))) (let* ((name (font-instance-name font)) (truename (font-instance-truename font)) (available (and truename (mswindows-available-font-sizes truename device)))) (if (null available) nil (or (string-match mswindows-font-regexp truename) (error "can't parse %S" truename)) (let ((old-size (string-to-int (substring truename (match-beginning 3) (match-end 3))))) (or (> old-size 0) (error "font truename has 0 pointsize?")) (or (string-match mswindows-font-regexp name) (error "can't parse %S" name)) (let ((newsize ;; scalable fonts: change size by 1 point. (if (= 0 (car available)) (if (and (not up-p) (= 1 old-size)) nil (if up-p (1+ old-size) (1- old-size))) ;; non-scalable fonts: take the next available size. (if up-p (loop for tail on available if (eql (car tail) old-size) return (cadr tail)) (loop for tail on available if (eql (cadr tail) old-size) return (car tail)))))) (and newsize (concat (substring name 0 (match-beginning 3)) (int-to-string newsize) (substring name (match-end 3) (match-end 0))))))))) (defun mswindows-find-smaller-font (font &optional device) "Loads a new version of the given font (or font name) 1 point smaller. Returns the font if it succeeds, nil otherwise." (mswindows-frob-font-size font nil device)) (defun mswindows-find-larger-font (font &optional device) "Loads a new version of the given font (or font name) 1 point larger. Returns the font if it succeeds, nil otherwise." (mswindows-frob-font-size font t device))