annotate lisp/gtk-font-menu.el @ 4885:6772ce4d982b

Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums lisp/ChangeLog addition: 2010-01-24 Aidan Kehoe <kehoea@parhasard.net> Correct the semantics of #'member*, #'eql, #'assoc* in the presence of bignums; change the integerp byte code to fixnump semantics. * bytecomp.el (fixnump, integerp, byte-compile-integerp): Change the integerp byte code to fixnump; add a byte-compile method to integerp using fixnump and numberp and avoiding a funcall most of the time, since in the non-core contexts where integerp is used, it's mostly distinguishing between fixnums and things that are not numbers at all. * byte-optimize.el (side-effect-free-fns, byte-after-unbind-ops) (byte-compile-side-effect-and-error-free-ops): Replace the integerp bytecode with fixnump; add fixnump to the side-effect-free-fns. Add the other extended number type predicates to the list in passing. * obsolete.el (floatp-safe): Mark this as obsolete. * cl.el (eql): Go into more detail in the docstring here. Don't bother checking whether both arguments are numbers; one is enough, #'equal will fail correctly if they have distinct types. (subst): Replace a call to #'integerp (deciding whether to use #'memq or not) with one to #'fixnump. Delete most-positive-fixnum, most-negative-fixnum from this file; they're now always in C, so they can't be modified from Lisp. * cl-seq.el (member*, assoc*, rassoc*): Correct these functions in the presence of bignums. * cl-macs.el (cl-make-type-test): The type test for a fixnum is now fixnump. Ditch floatp-safe, use floatp instead. (eql): Correct this compiler macro in the presence of bignums. (assoc*): Correct this compiler macro in the presence of bignums. * simple.el (undo): Change #'integerp to #'fixnump here, since we use #'delq with the same value as ELT a few lines down. src/ChangeLog addition: 2010-01-24 Aidan Kehoe <kehoea@parhasard.net> Fix problems with #'eql, extended number types, and the hash table implementation; change the Bintegerp bytecode to fixnump semantics even on bignum builds, since #'integerp can have a fast implementation in terms of #'fixnump for most of its extant uses, but not vice-versa. * lisp.h: Always #include number.h; we want the macros provided in it, even if the various number types are not available. * number.h (NON_FIXNUM_NUMBER_P): New macro, giving 1 when its argument is of non-immediate number type. Equivalent to FLOATP if WITH_NUMBER_TYPES is not defined. * elhash.c (lisp_object_eql_equal, lisp_object_eql_hash): Use NON_FIXNUM_NUMBER_P in these functions, instead of FLOATP, giving more correct behaviour in the presence of the extended number types. * bytecode.c (Bfixnump, execute_optimized_program): Rename Bintegerp to Bfixnump; change its semantics to reflect the new name on builds with bignum support. * data.c (Ffixnump, Fintegerp, syms_of_data, vars_of_data): Always make #'fixnump available, even on non-BIGNUM builds; always implement #'integerp in this file, even on BIGNUM builds. Move most-positive-fixnum, most-negative-fixnum here from number.c, so they are Lisp constants even on builds without number types, and attempts to change or bind them error. Use the NUMBERP and INTEGERP macros even on builds without extended number types. * data.c (fixnum_char_or_marker_to_int): Rename this function from integer_char_or_marker_to_int, to better reflect the arguments it accepts. * number.c (Fevenp, Foddp, syms_of_number): Never provide #'integerp in this file. Remove #'oddp, #'evenp; their implementations are overridden by those in cl.el. * number.c (vars_of_number): most-positive-fixnum, most-negative-fixnum are no longer here. man/ChangeLog addition: 2010-01-23 Aidan Kehoe <kehoea@parhasard.net> Generally: be careful to say fixnum, not integer, when talking about fixed-precision integral types. I'm sure I've missed instances, both here and in the docstrings, but this is a decent start. * lispref/text.texi (Columns): Document where only fixnums, not integers generally, are accepted. (Registers): Remove some ancient char-int confoundance here. * lispref/strings.texi (Creating Strings, Creating Strings): Be more exact in describing where fixnums but not integers in general are accepted. (Creating Strings): Use a more contemporary example to illustrate how concat deals with lists including integers about #xFF. Delete some obsolete documentation on same. (Char Table Types): Document that only fixnums are accepted as values in syntax tables. * lispref/searching.texi (String Search, Search and Replace): Be exact in describing where fixnums but not integers in general are accepted. * lispref/range-tables.texi (Range Tables): Be exact in describing them; only fixnums are accepted to describe ranges. * lispref/os.texi (Killing XEmacs, User Identification) (Time of Day, Time Conversion): Be more exact about using fixnum where only fixed-precision integers are accepted. * lispref/objects.texi (Integer Type): Be more exact (and up-to-date) about the possible values for integers. Cross-reference to documentation of the bignum extension. (Equality Predicates): (Range Table Type): (Array Type): Use fixnum, not integer, to describe a fixed-precision integer. (Syntax Table Type): Correct some English syntax here. * lispref/numbers.texi (Numbers): Change the phrasing here to use fixnum to mean the fixed-precision integers normal in emacs. Document that our terminology deviates from that of Common Lisp, and that we're working on it. (Compatibility Issues): Reiterate the Common Lisp versus Emacs Lisp compatibility issues. (Comparison of Numbers, Arithmetic Operations): * lispref/commands.texi (Command Loop Info, Working With Events): * lispref/buffers.texi (Modification Time): Be more exact in describing where fixnums but not integers in general are accepted.
author Aidan Kehoe <kehoea@parhasard.net>
date Sun, 24 Jan 2010 15:21:27 +0000
parents b4f4e0cc90f1
children 2a54dfbe434f 308d34e9f07d
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
462
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
1 ;; gtk-font-menu.el --- Managing menus of GTK fonts.
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
2
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
3 ;; Copyright (C) 1994 Free Software Foundation, Inc.
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
4 ;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp.
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
5 ;; Copyright (C) 1997 Sun Microsystems
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
6
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
7 ;; Author: Jamie Zawinski <jwz@jwz.org>
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
8 ;; Restructured by: Jonathan Stigelman <Stig@hackvan.com>
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
9 ;; Mule-ized by: Martin Buchholz
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
10 ;; More restructuring for MS-Windows by Andy Piper <andy@xemacs.org>
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
11 ;; GTK-ized by: William Perry <wmperry@xemacs.org>
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
12
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
13 ;; This file is part of XEmacs.
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
14
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
15 ;; XEmacs is free software; you can redistribute it and/or modify it
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
16 ;; under the terms of the GNU General Public License as published by
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
17 ;; the Free Software Foundation; either version 2, or (at your option)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
18 ;; any later version.
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
19
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
20 ;; XEmacs is distributed in the hope that it will be useful, but
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
21 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
22 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
23 ;; General Public License for more details.
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
24
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
25 ;; You should have received a copy of the GNU General Public License
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
26 ;; along with XEmacs; see the file COPYING. If not, write to the
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
27 ;; Free Software Foundation, 59 Temple Place - Suite 330,
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
28 ;; Boston, MA 02111-1307, USA.
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
29 ;;; Code:
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
30
2297
13a418960a88 [xemacs-hg @ 2004-09-22 02:05:42 by stephent]
stephent
parents: 1104
diff changeset
31 ;; #### - The comment that this file was GTK-ized by Wm Perry is a lie;
13a418960a88 [xemacs-hg @ 2004-09-22 02:05:42 by stephent]
stephent
parents: 1104
diff changeset
32 ;; nothing was done except to rename everything that was x- to gtk-.
13a418960a88 [xemacs-hg @ 2004-09-22 02:05:42 by stephent]
stephent
parents: 1104
diff changeset
33 ;; This is harmless, but we should reintegrate so that GTK can take
13a418960a88 [xemacs-hg @ 2004-09-22 02:05:42 by stephent]
stephent
parents: 1104
diff changeset
34 ;; advantage of fontconfig, too, I think.
13a418960a88 [xemacs-hg @ 2004-09-22 02:05:42 by stephent]
stephent
parents: 1104
diff changeset
35
462
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
36 ;; #### - implement these...
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
37 ;;
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
38 ;;; (defvar font-menu-ignore-proportional-fonts nil
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
39 ;;; "*If non-nil, then the font menu will only show fixed-width fonts.")
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
40
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
41 (require 'font-menu)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
42
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 462
diff changeset
43 (globally-declare-boundp
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 462
diff changeset
44 '(gtk-font-regexp
2297
13a418960a88 [xemacs-hg @ 2004-09-22 02:05:42 by stephent]
stephent
parents: 1104
diff changeset
45 gtk-font-regexp-foundry-and-family
13a418960a88 [xemacs-hg @ 2004-09-22 02:05:42 by stephent]
stephent
parents: 1104
diff changeset
46 gtk-font-regexp-spacing))
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 462
diff changeset
47
462
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
48 (defvar gtk-font-menu-registry-encoding nil
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
49 "Registry and encoding to use with font menu fonts.")
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
50
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
51 (defvar gtk-fonts-menu-junk-families
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
52 (mapconcat
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
53 #'identity
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
54 '("cursor" "glyph" "symbol" ; Obvious losers.
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
55 "\\`Ax...\\'" ; FrameMaker fonts - there are just way too
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
56 ; many of these, and there is a different
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
57 ; font family for each font face! Losers.
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
58 ; "Axcor" -> "Applix Courier Roman",
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
59 ; "Axcob" -> "Applix Courier Bold", etc.
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
60 )
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
61 "\\|")
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
62 "A regexp matching font families which are uninteresting (e.g. cursor fonts).")
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
63
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
64 (defun hack-font-truename (fn)
2297
13a418960a88 [xemacs-hg @ 2004-09-22 02:05:42 by stephent]
stephent
parents: 1104
diff changeset
65 ;; #### This is duplicated from x-font-menu.el.
13a418960a88 [xemacs-hg @ 2004-09-22 02:05:42 by stephent]
stephent
parents: 1104
diff changeset
66 "Filter the output of `font-instance-truename' to deal with font sets."
462
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
67 (if (string-match "," (font-instance-truename fn))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
68 (let ((fpnt (nth 8 (split-string (font-instance-name fn) "-")))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
69 (flist (split-string (font-instance-truename fn) ","))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
70 ret)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
71 (while flist
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
72 (if (string-equal fpnt (nth 8 (split-string (car flist) "-")))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
73 (progn (setq ret (car flist)) (setq flist nil))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
74 (setq flist (cdr flist))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
75 ))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
76 ret)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
77 (font-instance-truename fn)))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
78
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
79 (defvar gtk-font-regexp-ascii nil
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
80 "This is used to filter out font families that can't display ASCII text.
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
81 It must be set at run-time.")
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
82
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
83 ;;;###autoload
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
84 (defun gtk-reset-device-font-menus (device &optional debug)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
85 "Generates the `Font', `Size', and `Weight' submenus for the Options menu.
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
86 This is run the first time that a font-menu is needed for each device.
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
87 If you don't like the lazy invocation of this function, you can add it to
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
88 `create-device-hook' and that will make the font menus respond more quickly
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
89 when they are selected for the first time. If you add fonts to your system,
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
90 or if you change your font path, you can call this to re-initialize the menus."
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
91 ;; by Stig@hackvan.com
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
92 ;; #### - this should implement a `menus-only' option, which would
2527
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 2297
diff changeset
93 ;; recalculate the menus from the cache w/o having to do font-list again.
462
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
94 (unless gtk-font-regexp-ascii
4103
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan]
aidan
parents: 2527
diff changeset
95 (setq gtk-font-regexp-ascii (if-fboundp #'charset-registries
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan]
aidan
parents: 2527
diff changeset
96 (aref (charset-registries 'ascii) 0)
b4f4e0cc90f1 [xemacs-hg @ 2007-08-07 23:08:47 by aidan]
aidan
parents: 2527
diff changeset
97 "iso8859-1")))
462
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
98 (setq gtk-font-menu-registry-encoding
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
99 (if (featurep 'mule) "*-*" "iso8859-1"))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
100 (let ((case-fold-search t)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
101 family size weight entry monospaced-p
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
102 dev-cache cache families sizes weights)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
103 (dolist (name (cond ((null debug) ; debugging kludge
2527
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 2297
diff changeset
104 (font-list "*-*-*-*-*-*-*-*-*-*-*-*-*-*" device))
462
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
105 ((stringp debug) (split-string debug "\n"))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
106 (t debug)))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
107 (when (and (string-match gtk-font-regexp-ascii name)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
108 (string-match gtk-font-regexp name))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
109 (setq weight (capitalize (match-string 1 name))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
110 size (string-to-int (match-string 6 name)))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
111 (or (string-match gtk-font-regexp-foundry-and-family name)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
112 (error "internal error"))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
113 (setq family (capitalize (match-string 1 name)))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
114 (or (string-match gtk-font-regexp-spacing name)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
115 (error "internal error"))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
116 (setq monospaced-p (string= "m" (match-string 1 name)))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
117 (unless (string-match gtk-fonts-menu-junk-families family)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
118 (setq entry (or (vassoc family cache)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
119 (car (setq cache
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
120 (cons (vector family nil nil t)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
121 cache)))))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
122 (or (member family families) (push family families))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
123 (or (member weight weights) (push weight weights))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
124 (or (member size sizes) (push size sizes))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
125 (or (member weight (aref entry 1)) (push weight (aref entry 1)))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
126 (or (member size (aref entry 2)) (push size (aref entry 2)))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
127 (aset entry 3 (and (aref entry 3) monospaced-p)))))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
128 ;;
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
129 ;; Hack scalable fonts.
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
130 ;; Some fonts come only in scalable versions (the only size is 0)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
131 ;; and some fonts come in both scalable and non-scalable versions
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
132 ;; (one size is 0). If there are any scalable fonts at all, make
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
133 ;; sure that the union of all point sizes contains at least some
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
134 ;; common sizes - it's possible that some sensible sizes might end
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
135 ;; up not getting mentioned explicitly.
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
136 ;;
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
137 (if (member 0 sizes)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
138 (let ((common '(60 80 100 120 140 160 180 240)))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
139 (while common
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
140 (or;;(member (car common) sizes) ; not enough slack
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
141 (let ((rest sizes)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
142 (done nil))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
143 (while (and (not done) rest)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
144 (if (and (> (car common) (- (car rest) 5))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
145 (< (car common) (+ (car rest) 5)))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
146 (setq done t))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
147 (setq rest (cdr rest)))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
148 done)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
149 (setq sizes (cons (car common) sizes)))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
150 (setq common (cdr common)))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
151 (setq sizes (delq 0 sizes))))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
152
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
153 (setq families (sort families 'string-lessp)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
154 weights (sort weights 'string-lessp)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
155 sizes (sort sizes '<))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
156
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
157 (dolist (entry cache)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
158 (aset entry 1 (sort (aref entry 1) 'string-lessp))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
159 (aset entry 2 (sort (aref entry 2) '<)))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
160
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
161 (setq dev-cache (assq device device-fonts-cache))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
162 (or dev-cache
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
163 (setq dev-cache (car (push (list device) device-fonts-cache))))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
164 (setcdr
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
165 dev-cache
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
166 (vector
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
167 cache
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
168 (mapcar (lambda (x)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
169 (vector x
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
170 (list 'font-menu-set-font x nil nil)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
171 ':style 'radio ':active nil ':selected nil))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
172 families)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
173 (mapcar (lambda (x)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
174 (vector (if (/= 0 (% x 10))
1104
8b464283e891 [xemacs-hg @ 2002-11-12 18:58:13 by james]
james
parents: 502
diff changeset
175 (number-to-string (/ x 10.0))
8b464283e891 [xemacs-hg @ 2002-11-12 18:58:13 by james]
james
parents: 502
diff changeset
176 (number-to-string (/ x 10)))
462
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
177 (list 'font-menu-set-font nil nil x)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
178 ':style 'radio ':active nil ':selected nil))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
179 sizes)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
180 (mapcar (lambda (x)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
181 (vector x
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
182 (list 'font-menu-set-font nil x nil)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
183 ':style 'radio ':active nil ':selected nil))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
184 weights)))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
185 (cdr dev-cache)))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
186
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
187 ;; Extract font information from a face. We examine both the
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
188 ;; user-specified font name and the canonical (`true') font name.
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
189 ;; These can appear to have totally different properties.
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
190 ;; For examples, see the prolog above.
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
191
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
192 ;; We use the user-specified one if possible, else use the truename.
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
193 ;; If the user didn't specify one (with "-dt-*-*", for example)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
194 ;; get the truename and use the possibly suboptimal data from that.
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
195 ;;;###autoload
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
196 (defun* gtk-font-menu-font-data (face dcache)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
197 (defvar gtk-font-regexp)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
198 (defvar gtk-font-regexp-foundry-and-family)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
199 (let* ((case-fold-search t)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
200 (domain (if font-menu-this-frame-only-p
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
201 (selected-frame)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
202 (selected-device)))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
203 (name (font-instance-name (face-font-instance face domain)))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
204 (truename (font-instance-truename
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
205 (face-font-instance face domain
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
206 (if (featurep 'mule) 'ascii))))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
207 family size weight entry slant)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
208 (when (string-match gtk-font-regexp-foundry-and-family name)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
209 (setq family (capitalize (match-string 1 name)))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
210 (setq entry (vassoc family (aref dcache 0))))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
211 (when (and (null entry)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
212 (string-match gtk-font-regexp-foundry-and-family truename))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
213 (setq family (capitalize (match-string 1 truename)))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
214 (setq entry (vassoc family (aref dcache 0))))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
215 (when (null entry)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
216 (return-from gtk-font-menu-font-data (make-vector 5 nil)))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
217
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
218 (when (string-match gtk-font-regexp name)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
219 (setq weight (capitalize (match-string 1 name)))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
220 (setq size (string-to-int (match-string 6 name))))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
221
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
222 (when (string-match gtk-font-regexp truename)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
223 (when (not (member weight (aref entry 1)))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
224 (setq weight (capitalize (match-string 1 truename))))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
225 (when (not (member size (aref entry 2)))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
226 (setq size (string-to-int (match-string 6 truename))))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
227 (setq slant (capitalize (match-string 2 truename))))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
228
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
229 (vector entry family size weight slant)))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
230
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
231 (defun gtk-font-menu-load-font (family weight size slant resolution)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
232 "Try to load a font with the requested properties.
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
233 The weight, slant and resolution are only hints."
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
234 (when (integerp size) (setq size (int-to-string size)))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
235 (let (font)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
236 (catch 'got-font
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
237 (dolist (weight (list weight "*"))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
238 (dolist (slant
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
239 (cond ((string-equal slant "O") '("O" "I" "*"))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
240 ((string-equal slant "I") '("I" "O" "*"))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
241 ((string-equal slant "*") '("*"))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
242 (t (list slant "*"))))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
243 (dolist (resolution
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
244 (if (string-equal resolution "*-*")
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
245 (list resolution)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
246 (list resolution "*-*")))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
247 (when (setq font
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
248 (make-font-instance
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
249 (concat "-*-" family "-" weight "-" slant "-*-*-*-"
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
250 size "-" resolution "-*-*-"
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
251 gtk-font-menu-registry-encoding)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
252 nil t))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
253 (throw 'got-font font))))))))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
254
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
255 (provide 'gtk-font-menu)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
256
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
257 ;;; gtk-font-menu.el ends here