annotate lisp/x-faces.el @ 5219:2d0937dc83cf

Tidying of CL files; make docstrings read better, remove commented-out code 2010-05-30 Aidan Kehoe <kehoea@parhasard.net> * cl.el: Remove extraneous empty lines. Remove the commented-out Lisp implementation of #'last, #'copy-list. Remove #'cl-maclisp-member. (acons, pairlis): Have the argument list reflect the docstring for these functions. * cl-macs.el (defun*): Have the argument list reflect the docstring. Document the syntax of keywords in ARGLIST. (defmacro*): Have the argument list reflect the docstring. Document &body, &whole and &environment. (function*): Have the argument list reflect the docstring. (loop): Have the argument list reflect the docstring. (eval-when, dolist, dotimes, do-symbols, flet, labels, macrolet, symbol-macrolet): Specify the argument list using the arguments: (...) syntax. (define-setf-method, rotatef, defsubst*): Have the argument list reflect the docstring. (letf, letf*): Specify the argument list using the arguments: (...) syntax. (svref, acons, pairlis): Add compiler macros for these functions. * cl-extra.el: Remove the commented-out Lisp implementation of #'equalp. If we want to look at it, it's in version control. (cl-expt): Remove this. The subr #'expt is always available. Call #'cl-float-limits at dump time. Remove the commented-out Lisp implementation of #'subseq. (concatenate): Use (error 'invalid-argument ...) here, if TYPE is not understood. (list-length): Don't manually get the length of a list, call #'length and return nil if the list is circular. * byte-optimize.el (equalp): This needs byte-optimize-binary-predicate as its optimizer, as do the other equality predicates.
author Aidan Kehoe <kehoea@parhasard.net>
date Sun, 30 May 2010 13:27:36 +0100
parents 8b2f75cecb89
children 668c73e222fd
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1 ;;; x-faces.el --- X-specific face frobnication, aka black magic.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2
3360
316fddbf58e2 [xemacs-hg @ 2006-04-25 14:01:52 by stephent]
stephent
parents: 3354
diff changeset
3 ;; Copyright (C) 1992-1994, 1997, 2006 Free Software Foundation, Inc.
2527
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
4 ;; Copyright (C) 1995, 1996, 2002, 2004 Ben Wing.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6 ;; Author: Jamie Zawinski <jwz@jwz.org>
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
7 ;; Maintainer: XEmacs Development Team
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
8 ;; Keywords: extensions, internal, dumped
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
9
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
10 ;; This file is part of XEmacs.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
11
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
12 ;; XEmacs is free software; you can redistribute it and/or modify it
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
13 ;; under the terms of the GNU General Public License as published by
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
14 ;; the Free Software Foundation; either version 2, or (at your option)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
15 ;; any later version.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
16
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
17 ;; XEmacs is distributed in the hope that it will be useful, but
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
20 ;; General Public License for more details.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
21
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
22 ;; You should have received a copy of the GNU General Public License
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
23 ;; along with XEmacs; see the file COPYING. If not, write to the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
25 ;; Boston, MA 02111-1307, USA.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
26
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
27 ;;; Synched up with: Not synched.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
28
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
29 ;;; Commentary:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
30
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
31 ;; This file is dumped with XEmacs (when X support is compiled in).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
32
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
33 ;; Modified by: Chuck Thompson
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
34 ;; Modified by: Ben Wing
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
35 ;; Modified by: Martin Buchholz
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
36
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
37 ;; This file does the magic to parse X font names, and make sure that the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
38 ;; default and modeline attributes of new frames are specified enough.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
39
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
40 ;; The resource-manager syntax for faces is
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
41
2703
2f2d12f4f93a [xemacs-hg @ 2005-03-31 11:28:41 by aidan]
aidan
parents: 2527
diff changeset
42 ;; XEmacs.bold.attributeFont: font-name
2f2d12f4f93a [xemacs-hg @ 2005-03-31 11:28:41 by aidan]
aidan
parents: 2527
diff changeset
43 ;; XEmacs.bold.attributeForeground: fg
2f2d12f4f93a [xemacs-hg @ 2005-03-31 11:28:41 by aidan]
aidan
parents: 2527
diff changeset
44 ;; XEmacs.bold.attributeBackground: bg
2f2d12f4f93a [xemacs-hg @ 2005-03-31 11:28:41 by aidan]
aidan
parents: 2527
diff changeset
45 ;; XEmacs.bold.attributeBackgroundPixmap: file
2f2d12f4f93a [xemacs-hg @ 2005-03-31 11:28:41 by aidan]
aidan
parents: 2527
diff changeset
46 ;; XEmacs.bold.attributeUnderline: true/false
2f2d12f4f93a [xemacs-hg @ 2005-03-31 11:28:41 by aidan]
aidan
parents: 2527
diff changeset
47 ;; XEmacs.bold.attributeStrikethru: true/false
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
48
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
49 ;; You can specify the properties of a face on a per-frame basis. For
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
50 ;; example, to have the "isearch" face use a red foreground on frames
2703
2f2d12f4f93a [xemacs-hg @ 2005-03-31 11:28:41 by aidan]
aidan
parents: 2527
diff changeset
51 ;; named "XEmacs" (the default) but use a blue foreground on frames that
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
52 ;; you create named "debugger", you could do
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
53
2703
2f2d12f4f93a [xemacs-hg @ 2005-03-31 11:28:41 by aidan]
aidan
parents: 2527
diff changeset
54 ;; XEmacs*XEmacs.isearch.attributeForeground: red
2f2d12f4f93a [xemacs-hg @ 2005-03-31 11:28:41 by aidan]
aidan
parents: 2527
diff changeset
55 ;; XEmacs*debugger.isearch.attributeForeground: blue
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
56
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
57 ;; Generally things that make faces won't set any of the face attributes if
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
58 ;; you have already given them values via the resource database. You can
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
59 ;; also change this stuff from your .emacs file, by using the functions
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
60 ;; set-face-foreground, set-face-font, etc. See the code in this file, and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
61 ;; in faces.el.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
62
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
63 ;;; Code:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
64
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
65 (globally-declare-fboundp
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
66 '(x-get-resource-and-maybe-bogosity-check
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
67 x-get-resource x-init-pointer-shape))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 444
diff changeset
68
3354
15fb91e3a115 [xemacs-hg @ 2006-04-23 16:11:16 by stephent]
stephent
parents: 3125
diff changeset
69 (if (featurep 'xft-fonts)
15fb91e3a115 [xemacs-hg @ 2006-04-23 16:11:16 by stephent]
stephent
parents: 3125
diff changeset
70 (require 'fontconfig)
15fb91e3a115 [xemacs-hg @ 2006-04-23 16:11:16 by stephent]
stephent
parents: 3125
diff changeset
71 (globally-declare-boundp
15fb91e3a115 [xemacs-hg @ 2006-04-23 16:11:16 by stephent]
stephent
parents: 3125
diff changeset
72 '(fc-font-name-weight-bold fc-font-name-weight-black
15fb91e3a115 [xemacs-hg @ 2006-04-23 16:11:16 by stephent]
stephent
parents: 3125
diff changeset
73 fc-font-name-weight-demibold fc-font-name-weight-medium
15fb91e3a115 [xemacs-hg @ 2006-04-23 16:11:16 by stephent]
stephent
parents: 3125
diff changeset
74 fc-font-name-slant-oblique fc-font-name-slant-italic
15fb91e3a115 [xemacs-hg @ 2006-04-23 16:11:16 by stephent]
stephent
parents: 3125
diff changeset
75 fc-font-name-slant-roman))
15fb91e3a115 [xemacs-hg @ 2006-04-23 16:11:16 by stephent]
stephent
parents: 3125
diff changeset
76 (globally-declare-fboundp
3918
049dc907c17a [xemacs-hg @ 2007-04-22 19:58:27 by aidan]
aidan
parents: 3747
diff changeset
77 '(fc-font-match fc-pattern-del-size fc-pattern-get-size
049dc907c17a [xemacs-hg @ 2007-04-22 19:58:27 by aidan]
aidan
parents: 3747
diff changeset
78 fc-pattern-add-size fc-pattern-del-style fc-pattern-duplicate
049dc907c17a [xemacs-hg @ 2007-04-22 19:58:27 by aidan]
aidan
parents: 3747
diff changeset
79 fc-copy-pattern-partial fc-pattern-add-weight fc-pattern-del-weight
049dc907c17a [xemacs-hg @ 2007-04-22 19:58:27 by aidan]
aidan
parents: 3747
diff changeset
80 fc-try-font fc-pattern-del-slant fc-pattern-add-slant fc-name-parse
049dc907c17a [xemacs-hg @ 2007-04-22 19:58:27 by aidan]
aidan
parents: 3747
diff changeset
81 fc-name-unparse fc-pattern-get-pixelsize)))
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
82
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
83 (defconst x-font-regexp nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
84 (defconst x-font-regexp-head nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
85 (defconst x-font-regexp-head-2 nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
86 (defconst x-font-regexp-weight nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
87 (defconst x-font-regexp-slant nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
88 (defconst x-font-regexp-pixel nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
89 (defconst x-font-regexp-point nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
90 (defconst x-font-regexp-foundry-and-family nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
91 (defconst x-font-regexp-registry-and-encoding nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
92 (defconst x-font-regexp-spacing nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
93
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
94 ;;; Regexps matching font names in "Host Portable Character Representation."
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
95 ;;; #### But more recently Latin-1 is permitted, and Xft needs it in C (?).
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
96 ;;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
97 (let ((- "[-?]")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
98 (foundry "[^-]*")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
99 (family "[^-]*")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
100 (weight "\\(bold\\|demibold\\|medium\\|black\\)") ; 1
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
101 ; (weight\? "\\(\\*\\|bold\\|demibold\\|medium\\|\\)") ; 1
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
102 (weight\? "\\([^-]*\\)") ; 1
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
103 (slant "\\([ior]\\)") ; 2
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
104 ; (slant\? "\\([ior?*]?\\)") ; 2
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
105 (slant\? "\\([^-]?\\)") ; 2
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
106 ; (swidth "\\(\\*\\|normal\\|semicondensed\\|\\)") ; 3
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
107 (swidth "\\([^-]*\\)") ; 3
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
108 ; (adstyle "\\(\\*\\|sans\\|\\)") ; 4
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
109 (adstyle "\\([^-]*\\)") ; 4
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
110 (pixelsize "\\(\\*\\|[0-9]+\\)") ; 5
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
111 (pointsize "\\(\\*\\|0\\|[0-9][0-9]+\\)") ; 6
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
112 ; (resx "\\(\\*\\|[0-9][0-9]+\\)") ; 7
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
113 ; (resy "\\(\\*\\|[0-9][0-9]+\\)") ; 8
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
114 (resx "\\([*0]\\|[0-9][0-9]+\\)") ; 7
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
115 (resy "\\([*0]\\|[0-9][0-9]+\\)") ; 8
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
116 (spacing "[cmp?*]")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
117 (avgwidth "\\(\\*\\|[0-9]+\\)") ; 9
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
118 (registry "[^-]*") ; some fonts have omitted registries
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
119 ; (encoding ".+") ; note that encoding may contain "-"...
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
120 (encoding "[^-]+") ; false!
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
121 )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
122 (setq x-font-regexp
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
123 (concat "\\`\\*?[-?*]"
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
124 foundry - family - weight\? - slant\? - swidth - adstyle -
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
125 pixelsize - pointsize - resx - resy - spacing - avgwidth -
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
126 registry - encoding "\\'"
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
127 ))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
128 (setq x-font-regexp-head
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
129 (concat "\\`[-?*]" foundry - family - weight\? - slant\?
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
130 "\\([-*?]\\|\\'\\)"))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
131 (setq x-font-regexp-head-2
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
132 (concat "\\`[-?*]" foundry - family - weight\? - slant\?
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
133 - swidth - adstyle - pixelsize - pointsize
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
134 "\\([-*?]\\|\\'\\)"))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
135 (setq x-font-regexp-slant (concat - slant -))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
136 (setq x-font-regexp-weight (concat - weight -))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
137 ;; if we can't match any of the more specific regexps (unfortunate) then
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
138 ;; look for digits; assume 2+ digits is 10ths of points, and 1-2 digits
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
139 ;; is pixels. Bogus as hell.
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
140 (setq x-font-regexp-pixel "[-?*]\\([0-9][0-9]?\\)[-?*]")
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
141 (setq x-font-regexp-point "[-?*]\\([0-9][0-9]+\\)[-?*]")
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
142 ;; the following two are used by x-font-menu.el.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
143 (setq x-font-regexp-foundry-and-family
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
144 (concat "\\`[-?*]" foundry - "\\(" family "\\)" -))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
145 (setq x-font-regexp-registry-and-encoding
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
146 (concat - "\\(" registry "\\)" - "\\(" encoding "\\)\\'"))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
147 (setq x-font-regexp-spacing
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
148 (concat - "\\(" spacing "\\)" - avgwidth
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
149 - registry - encoding "\\'"))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
150 )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
151
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
152 (defun x-font-xlfd-font-name-p (font)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
153 "Check if FONT is an XLFD font name"
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
154 (and (stringp font)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
155 (string-match x-font-regexp font)))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
156
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
157 ;; A "loser font" is something like "8x13" -> "8x13bold".
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
158 ;; These are supported only through extreme generosity.
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
159 (defconst x-loser-font-regexp "\\`[0-9]+x[0-9]+\\'")
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
160
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
161 (defun x-frob-font-weight (font which)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
162 (if (font-instance-p font) (setq font (font-instance-name font)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
163 (cond ((null font) nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
164 ((or (string-match x-font-regexp font)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
165 (string-match x-font-regexp-head font)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
166 (string-match x-font-regexp-weight font))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
167 (concat (substring font 0 (match-beginning 1)) which
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
168 (substring font (match-end 1))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
169 ((string-match x-loser-font-regexp font)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
170 (concat font which))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
171 (t nil)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
172
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
173 (defun x-frob-font-slant (font which)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
174 (if (font-instance-p font) (setq font (font-instance-name font)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
175 (cond ((null font) nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
176 ((or (string-match x-font-regexp font)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
177 (string-match x-font-regexp-head font))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
178 (concat (substring font 0 (match-beginning 2)) which
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
179 (substring font (match-end 2))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
180 ((string-match x-font-regexp-slant font)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
181 (concat (substring font 0 (match-beginning 1)) which
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
182 (substring font (match-end 1))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
183 ((string-match x-loser-font-regexp font)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
184 (concat font which))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
185 (t nil)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
186
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
187 (defun x-make-font-bold (font &optional device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
188 "Given an X font specification, this attempts to make a `bold' font.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
189 If it fails, it returns nil."
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
190 (if (featurep 'xft-fonts)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
191 (if (x-font-xlfd-font-name-p font)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
192 (x-make-font-bold-core font device)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
193 (x-make-font-bold-xft font device))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
194 (x-make-font-bold-core font device)))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
195
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
196 (defun x-make-font-bold-xft (font &optional device)
3360
316fddbf58e2 [xemacs-hg @ 2006-04-25 14:01:52 by stephent]
stephent
parents: 3354
diff changeset
197 (let ((pattern (fc-font-match (or device (default-x-device))
316fddbf58e2 [xemacs-hg @ 2006-04-25 14:01:52 by stephent]
stephent
parents: 3354
diff changeset
198 (fc-name-parse font))))
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
199 (if pattern
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
200 (let ((size (fc-pattern-get-size pattern 0))
3354
15fb91e3a115 [xemacs-hg @ 2006-04-23 16:11:16 by stephent]
stephent
parents: 3125
diff changeset
201 (copy (fc-copy-pattern-partial pattern (list "family"))))
15fb91e3a115 [xemacs-hg @ 2006-04-23 16:11:16 by stephent]
stephent
parents: 3125
diff changeset
202 (fc-pattern-del-weight copy)
15fb91e3a115 [xemacs-hg @ 2006-04-23 16:11:16 by stephent]
stephent
parents: 3125
diff changeset
203 (fc-pattern-del-style copy)
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
204 (when copy
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
205 (or
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
206 ;; try bold font
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
207 (let ((copy-2 (fc-pattern-duplicate copy)))
3354
15fb91e3a115 [xemacs-hg @ 2006-04-23 16:11:16 by stephent]
stephent
parents: 3125
diff changeset
208 (fc-pattern-add-weight copy-2 fc-font-name-weight-bold)
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
209 (when (fc-try-font copy-2 device)
3354
15fb91e3a115 [xemacs-hg @ 2006-04-23 16:11:16 by stephent]
stephent
parents: 3125
diff changeset
210 (fc-pattern-add-size copy-2 size)
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
211 (fc-name-unparse copy-2)))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
212 ;; try black font
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
213 (let ((copy-2 (fc-pattern-duplicate copy)))
3354
15fb91e3a115 [xemacs-hg @ 2006-04-23 16:11:16 by stephent]
stephent
parents: 3125
diff changeset
214 (fc-pattern-add-weight copy-2 fc-font-name-weight-black)
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
215 (when (fc-try-font copy-2 device)
3354
15fb91e3a115 [xemacs-hg @ 2006-04-23 16:11:16 by stephent]
stephent
parents: 3125
diff changeset
216 (fc-pattern-add-size copy-2 size)
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
217 (fc-name-unparse copy-2)))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
218 ;; try demibold font
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
219 (let ((copy-2 (fc-pattern-duplicate copy)))
3354
15fb91e3a115 [xemacs-hg @ 2006-04-23 16:11:16 by stephent]
stephent
parents: 3125
diff changeset
220 (fc-pattern-add-weight copy-2 fc-font-name-weight-demibold)
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
221 (when (fc-try-font copy-2 device)
3354
15fb91e3a115 [xemacs-hg @ 2006-04-23 16:11:16 by stephent]
stephent
parents: 3125
diff changeset
222 (fc-pattern-add-size copy-2 size)
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
223 (fc-name-unparse copy-2)))))))))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
224
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
225 (defun x-make-font-bold-core (font &optional device)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
226 ;; Certain Type1 fonts know "bold" as "black"...
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
227 (or (try-font-name (x-frob-font-weight font "bold") device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
228 (try-font-name (x-frob-font-weight font "black") device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
229 (try-font-name (x-frob-font-weight font "demibold") device)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
230
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
231 (defun x-make-font-unbold (font &optional device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
232 "Given an X font specification, this attempts to make a non-bold font.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
233 If it fails, it returns nil."
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
234 (if (featurep 'xft-fonts)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
235 (if (x-font-xlfd-font-name-p font)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
236 (x-make-font-unbold-core font device)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
237 (x-make-font-unbold-xft font device))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
238 (x-make-font-unbold-core font device)))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
239
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
240 (defun x-make-font-unbold-xft (font &optional device)
3360
316fddbf58e2 [xemacs-hg @ 2006-04-25 14:01:52 by stephent]
stephent
parents: 3354
diff changeset
241 (let ((pattern (fc-font-match (or device (default-x-device))
316fddbf58e2 [xemacs-hg @ 2006-04-25 14:01:52 by stephent]
stephent
parents: 3354
diff changeset
242 (fc-name-parse font))))
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
243 (when pattern
3354
15fb91e3a115 [xemacs-hg @ 2006-04-23 16:11:16 by stephent]
stephent
parents: 3125
diff changeset
244 (fc-pattern-del-weight pattern)
15fb91e3a115 [xemacs-hg @ 2006-04-23 16:11:16 by stephent]
stephent
parents: 3125
diff changeset
245 (fc-pattern-add-weight pattern fc-font-name-weight-medium)
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
246 (if (fc-try-font pattern device)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
247 (fc-name-unparse pattern)))))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
248
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
249 (defun x-make-font-unbold-core (font &optional device)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
250 (try-font-name (x-frob-font-weight font "medium") device))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
251
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
252 (defcustom try-oblique-before-italic-fonts nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
253 "*If nil, italic fonts are searched before oblique fonts.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
254 If non-nil, oblique fonts are tried before italic fonts. This is mostly
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
255 applicable to adobe-courier fonts"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
256 :type 'boolean
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
257 :group 'x)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
258 (define-obsolete-variable-alias '*try-oblique-before-italic-fonts*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
259 'try-oblique-before-italic-fonts)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
260
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
261 (defun x-make-font-italic (font &optional device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
262 "Given an X font specification, this attempts to make an `italic' font.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
263 If it fails, it returns nil."
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
264 (if (featurep 'xft-fonts)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
265 (if (x-font-xlfd-font-name-p font)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
266 (x-make-font-italic-core font device)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
267 (x-make-font-italic-xft font device))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
268 (x-make-font-italic-core font device)))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
269
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
270 (defun x-make-font-italic-xft (font &optional device)
3360
316fddbf58e2 [xemacs-hg @ 2006-04-25 14:01:52 by stephent]
stephent
parents: 3354
diff changeset
271 (let ((pattern (fc-font-match (or device (default-x-device))
316fddbf58e2 [xemacs-hg @ 2006-04-25 14:01:52 by stephent]
stephent
parents: 3354
diff changeset
272 (fc-name-parse font))))
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
273 (if pattern
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
274 (let ((size (fc-pattern-get-size pattern 0))
3354
15fb91e3a115 [xemacs-hg @ 2006-04-23 16:11:16 by stephent]
stephent
parents: 3125
diff changeset
275 (copy (fc-copy-pattern-partial pattern (list "family"))))
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
276 (when copy
3354
15fb91e3a115 [xemacs-hg @ 2006-04-23 16:11:16 by stephent]
stephent
parents: 3125
diff changeset
277 (fc-pattern-del-slant copy)
15fb91e3a115 [xemacs-hg @ 2006-04-23 16:11:16 by stephent]
stephent
parents: 3125
diff changeset
278 (fc-pattern-del-style copy)
15fb91e3a115 [xemacs-hg @ 2006-04-23 16:11:16 by stephent]
stephent
parents: 3125
diff changeset
279 ;; #### can't we do this with one ambiguous pattern?
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
280 (let ((pattern-oblique (fc-pattern-duplicate copy))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
281 (pattern-italic (fc-pattern-duplicate copy)))
3354
15fb91e3a115 [xemacs-hg @ 2006-04-23 16:11:16 by stephent]
stephent
parents: 3125
diff changeset
282 (fc-pattern-add-slant pattern-oblique fc-font-name-slant-oblique)
15fb91e3a115 [xemacs-hg @ 2006-04-23 16:11:16 by stephent]
stephent
parents: 3125
diff changeset
283 (fc-pattern-add-slant pattern-italic fc-font-name-slant-italic)
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
284 (let ((have-oblique (fc-try-font pattern-oblique device))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
285 (have-italic (fc-try-font pattern-italic device)))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
286 (if try-oblique-before-italic-fonts
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
287 (if have-oblique
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
288 (progn
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
289 (if size
3354
15fb91e3a115 [xemacs-hg @ 2006-04-23 16:11:16 by stephent]
stephent
parents: 3125
diff changeset
290 (fc-pattern-add-size pattern-oblique size))
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
291 (fc-name-unparse pattern-oblique))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
292 (if have-italic
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
293 (progn
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
294 (if size
3354
15fb91e3a115 [xemacs-hg @ 2006-04-23 16:11:16 by stephent]
stephent
parents: 3125
diff changeset
295 (fc-pattern-add-size pattern-italic size))
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
296 (fc-name-unparse pattern-italic))))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
297 (if have-italic
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
298 (progn
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
299 (if size
3354
15fb91e3a115 [xemacs-hg @ 2006-04-23 16:11:16 by stephent]
stephent
parents: 3125
diff changeset
300 (fc-pattern-add-size pattern-italic size))
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
301 (fc-name-unparse pattern-italic))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
302 (if have-oblique
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
303 (progn
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
304 (if size
3354
15fb91e3a115 [xemacs-hg @ 2006-04-23 16:11:16 by stephent]
stephent
parents: 3125
diff changeset
305 (fc-pattern-add-size pattern-oblique size))
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
306 (fc-name-unparse pattern-oblique))))))))))))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
307
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
308 (defun x-make-font-italic-core (font &optional device)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
309 (if try-oblique-before-italic-fonts
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
310 (or (try-font-name (x-frob-font-slant font "o") device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
311 (try-font-name (x-frob-font-slant font "i") device))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
312 (or (try-font-name (x-frob-font-slant font "i") device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
313 (try-font-name (x-frob-font-slant font "o") device))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
314
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
315 (defun x-make-font-unitalic (font &optional device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
316 "Given an X font specification, this attempts to make a non-italic font.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
317 If it fails, it returns nil."
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
318 (if (featurep 'xft-fonts)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
319 (if (x-font-xlfd-font-name-p font)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
320 (x-make-font-unitalic-core font device)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
321 (x-make-font-unitalic-xft font device))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
322 (x-make-font-unitalic-core font device)))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
323
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
324 (defun x-make-font-unitalic-xft (font &optional device)
3360
316fddbf58e2 [xemacs-hg @ 2006-04-25 14:01:52 by stephent]
stephent
parents: 3354
diff changeset
325 (let ((pattern (fc-font-match (or device (default-x-device))
316fddbf58e2 [xemacs-hg @ 2006-04-25 14:01:52 by stephent]
stephent
parents: 3354
diff changeset
326 (fc-name-parse font))))
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
327 (when pattern
3354
15fb91e3a115 [xemacs-hg @ 2006-04-23 16:11:16 by stephent]
stephent
parents: 3125
diff changeset
328 (fc-pattern-del-slant pattern)
15fb91e3a115 [xemacs-hg @ 2006-04-23 16:11:16 by stephent]
stephent
parents: 3125
diff changeset
329 (fc-pattern-add-slant pattern fc-font-name-slant-roman)
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
330 (if (fc-try-font pattern device)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
331 (fc-name-unparse pattern)))))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
332
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
333 (defun x-make-font-unitalic-core (font &optional device)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
334 (try-font-name (x-frob-font-slant font "r") device))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
335
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
336 (defun x-make-font-bold-italic (font &optional device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
337 "Given an X font specification, this attempts to make a `bold-italic' font.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
338 If it fails, it returns nil."
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
339 (if (featurep 'xft-fonts)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
340 (if (x-font-xlfd-font-name-p font)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
341 (x-make-font-bold-italic-core font device)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
342 (x-make-font-bold-italic-xft font device))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
343 (x-make-font-bold-italic-core font device)))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
344
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
345 (defun x-make-font-bold-italic-xft (font &optional device)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
346 (let ((italic (x-make-font-italic-xft font device)))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
347 (if italic
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
348 (x-make-font-bold-xft italic device))))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
349
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
350 (defun x-make-font-bold-italic-core (font &optional device)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
351 ;; This is haired up to avoid loading the "intermediate" fonts.
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
352 (if try-oblique-before-italic-fonts
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
353 (or (try-font-name
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
354 (x-frob-font-slant (x-frob-font-weight font "bold") "o") device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
355 (try-font-name
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
356 (x-frob-font-slant (x-frob-font-weight font "bold") "i") device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
357 (try-font-name
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
358 (x-frob-font-slant (x-frob-font-weight font "black") "o") device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
359 (try-font-name
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
360 (x-frob-font-slant (x-frob-font-weight font "black") "i") device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
361 (try-font-name
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
362 (x-frob-font-slant (x-frob-font-weight font "demibold") "o") device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
363 (try-font-name
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
364 (x-frob-font-slant (x-frob-font-weight font "demibold") "i") device))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
365 (or (try-font-name
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
366 (x-frob-font-slant (x-frob-font-weight font "bold") "i") device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
367 (try-font-name
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
368 (x-frob-font-slant (x-frob-font-weight font "bold") "o") device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
369 (try-font-name
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
370 (x-frob-font-slant (x-frob-font-weight font "black") "i") device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
371 (try-font-name
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
372 (x-frob-font-slant (x-frob-font-weight font "black") "o") device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
373 (try-font-name
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
374 (x-frob-font-slant (x-frob-font-weight font "demibold") "i") device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
375 (try-font-name
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
376 (x-frob-font-slant (x-frob-font-weight font "demibold") "o") device))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
377
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
378 (defun x-font-size (font)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
379 "Return the nominal size of the given font.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
380 This is done by parsing its name, so it's likely to lose.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
381 X fonts can be specified (by the user) in either pixels or 10ths of points,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
382 and this returns the first one it finds, so you have to decide which units
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
383 the returned value is measured in yourself..."
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
384 (if (featurep 'xft-fonts)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
385 (if (x-font-xlfd-font-name-p font)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
386 (x-font-size-core font)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
387 (x-font-size-xft font))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
388 (x-font-size-core font)))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
389
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
390 ;; this is unbelievable &*@#
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
391 (defun x-font-size-xft (font)
3360
316fddbf58e2 [xemacs-hg @ 2006-04-25 14:01:52 by stephent]
stephent
parents: 3354
diff changeset
392 (let ((pattern (fc-font-match (default-x-device)
316fddbf58e2 [xemacs-hg @ 2006-04-25 14:01:52 by stephent]
stephent
parents: 3354
diff changeset
393 (fc-name-parse font))))
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
394 (when pattern
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
395 (let ((pixelsize (fc-pattern-get-pixelsize pattern 0)))
3360
316fddbf58e2 [xemacs-hg @ 2006-04-25 14:01:52 by stephent]
stephent
parents: 3354
diff changeset
396 (if (floatp pixelsize) (round pixelsize) pixelsize)))))
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
397
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
398 (defun x-font-size-core (font)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
399 (if (font-instance-p font) (setq font (font-instance-name font)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
400 (cond ((or (string-match x-font-regexp font)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
401 (string-match x-font-regexp-head-2 font))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
402 (string-to-int (substring font (match-beginning 6) (match-end 6))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
403 ((or (string-match x-font-regexp-pixel font)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
404 (string-match x-font-regexp-point font))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
405 (string-to-int (substring font (match-beginning 1) (match-end 1))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
406 (t nil)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
407
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
408 ;; Given a font name, this function returns a list describing all fonts
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
409 ;; of all sizes that otherwise match the given font spec. Each element
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
410 ;; in the list is a list of three items: the pixel size of the font,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
411 ;; the point size (in 1/10ths of a point) of the font, and the fully-
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
412 ;; qualified font name. The first two values may be zero; this
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
413 ;; refers to a scalable font.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
414
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
415 (defun x-available-font-sizes (font device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
416 (if (font-instance-p font) (setq font (font-instance-name font)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
417 (cond ((string-match x-font-regexp font)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
418 ;; turn pixelsize, pointsize, and avgwidth into wildcards
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
419 (setq font
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
420 (concat (substring font 0 (match-beginning 5)) "*"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
421 (substring font (match-end 5) (match-beginning 6)) "*"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
422 (substring font (match-end 6) (match-beginning 9)) "*"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
423 (substring font (match-end 9) (match-end 0)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
424 ((string-match x-font-regexp-head-2 font)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
425 ;; turn pixelsize and pointsize into wildcards
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
426 (setq font
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
427 (concat (substring font 0 (match-beginning 5)) "*"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
428 (substring font (match-end 5) (match-beginning 6)) "*"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
429 (substring font (match-end 6) (match-end 0)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
430 ((string-match "[-?*]\\([0-9]+\\)[-?*]" font)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
431 ;; Turn the first integer we match into a wildcard.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
432 ;; This is pretty dubious...
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
433 (setq font
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
434 (concat (substring font 0 (match-beginning 1)) "*"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
435 (substring font (match-end 1) (match-end 0))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
436 (sort
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
437 (delq nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
438 (mapcar (function
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
439 (lambda (name)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
440 (and (string-match x-font-regexp name)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
441 (list
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
442 (string-to-int (substring name (match-beginning 5)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
443 (match-end 5)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
444 (string-to-int (substring name (match-beginning 6)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
445 (match-end 6)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
446 name))))
2527
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
447 (font-list font device)))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
448 (function (lambda (x y) (if (= (nth 1 x) (nth 1 y))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
449 (< (nth 0 x) (nth 0 y))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
450 (< (nth 1 x) (nth 1 y)))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
451
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
452 ;; Given a font name, this attempts to construct a valid font name for
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
453 ;; DEVICE whose size is the next smaller (if UP-P is nil) or larger
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
454 ;; (if UP-P is t) size and whose other characteristics are the same
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
455 ;; as the given font.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
456
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
457 (defun x-frob-font-size (font up-p device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
458 (if (stringp font) (setq font (make-font-instance font device)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
459 (if (font-instance-p font) (setq font (font-instance-truename font)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
460 (let ((available (and font
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
461 (x-available-font-sizes font device))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
462 (cond
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
463 ((null available) nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
464 ((or (= 0 (nth 0 (car available)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
465 (= 0 (nth 1 (car available))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
466 ;; R5 scalable fonts: change size by 1 point.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
467 ;; If they're scalable the first font will have pixel or point = 0.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
468 ;; Sometimes one is 0 and the other isn't (if it's a bitmap font that
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
469 ;; can be scaled), sometimes both are (if it's a true outline font).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
470 (let ((name (nth 2 (car available)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
471 old-size)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
472 (or (string-match x-font-regexp font) (error "can't parse %S" font))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
473 (setq old-size (string-to-int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
474 (substring font (match-beginning 6) (match-end 6))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
475 (or (> old-size 0) (error "font truename has 0 pointsize?"))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
476 (or (string-match x-font-regexp name) (error "can't parse %S" name))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
477 ;; turn pixelsize into a wildcard, and make pointsize be +/- 10,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
478 ;; which is +/- 1 point. All other fields stay the same as they
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
479 ;; were in the "template" font returned by x-available-font-sizes.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
480 ;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
481 ;; #### But this might return the same font: for example, if the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
482 ;; truename of "-*-courier-medium-r-normal--*-230-75-75-m-0-*"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
483 ;; is "...-240-..." (instead of 230) then this loses, because
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
484 ;; the 230 that was passed in as an arg got turned into 240
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
485 ;; by the call to font-instance-truename; then we decrement that
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
486 ;; by 10 and return the result which is the same. I think the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
487 ;; way to fix this is to make this be a loop that keeps trying
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
488 ;; progressively larger pointsize deltas until it finds one
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
489 ;; whose truename differs. Have to be careful to avoid infinite
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
490 ;; loops at the upper end...
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
491 ;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
492 (concat (substring name 0 (match-beginning 5)) "*"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
493 (substring name (match-end 5) (match-beginning 6))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
494 (int-to-string (+ old-size (if up-p 10 -10)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
495 (substring name (match-end 6) (match-end 0)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
496 (t
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
497 ;; non-scalable fonts: take the next available size.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
498 (let ((rest available)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
499 (last nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
500 result)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
501 (while rest
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 502
diff changeset
502 (cond ((and (not up-p) (equalp font (nth 2 (car rest))))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
503 (setq result last
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
504 rest nil))
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 502
diff changeset
505 ((and up-p (equalp font (and last (nth 2 last))))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
506 (setq result (car rest)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
507 rest nil)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
508 (setq last (car rest))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
509 (setq rest (cdr rest)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
510 (nth 2 result))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
511
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
512 (defun x-find-smaller-font (font &optional device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
513 "Load a new, slightly smaller version of the given font (or font name).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
514 Returns the font if it succeeds, nil otherwise.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
515 If scalable fonts are available, this returns a font which is 1 point smaller.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
516 Otherwise, it returns the next smaller version of this font that is defined."
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
517 (if (featurep 'xft-fonts)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
518 (if (x-font-xlfd-font-name-p font)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
519 (x-find-smaller-font-core font device)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
520 (x-find-smaller-font-xft font device))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
521 (x-find-smaller-font-core font device)))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
522
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
523 (defun x-find-xft-font-of-size (font new-size-proc &optional device)
3360
316fddbf58e2 [xemacs-hg @ 2006-04-25 14:01:52 by stephent]
stephent
parents: 3354
diff changeset
524 (let* ((pattern (fc-font-match (or device (default-x-device))
316fddbf58e2 [xemacs-hg @ 2006-04-25 14:01:52 by stephent]
stephent
parents: 3354
diff changeset
525 (fc-name-parse font))))
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
526 (when pattern
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
527 (let ((size (fc-pattern-get-size pattern 0)))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
528 (if (floatp size)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
529 (let ((copy (fc-pattern-duplicate pattern)))
3354
15fb91e3a115 [xemacs-hg @ 2006-04-23 16:11:16 by stephent]
stephent
parents: 3125
diff changeset
530 (fc-pattern-del-size copy)
15fb91e3a115 [xemacs-hg @ 2006-04-23 16:11:16 by stephent]
stephent
parents: 3125
diff changeset
531 (fc-pattern-add-size copy (funcall new-size-proc size))
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
532 (if (fc-try-font font device)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
533 (fc-name-unparse copy))))))))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
534
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
535 (defun x-find-smaller-font-xft (font &optional device)
4021
cef5f57bb9e2 [xemacs-hg @ 2007-06-21 13:39:08 by aidan]
aidan
parents: 3918
diff changeset
536 (x-find-xft-font-of-size font #'(lambda (old-size) (- old-size 1.0)) device))
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
537
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
538 (defun x-find-smaller-font-core (font &optional device)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
539 (x-frob-font-size font nil device))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
540
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
541 (defun x-find-larger-font (font &optional device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
542 "Load a new, slightly larger version of the given font (or font name).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
543 Returns the font if it succeeds, nil otherwise.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
544 If scalable fonts are available, this returns a font which is 1 point larger.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
545 Otherwise, it returns the next larger version of this font that is defined."
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
546 (if (featurep 'xft-fonts)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
547 (if (x-font-xlfd-font-name-p font)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
548 (x-find-larger-font-core font device)
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
549 (x-find-larger-font-xft font device))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
550 (x-find-larger-font-core font device)))
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
551
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
552 (defun x-find-larger-font-xft (font &optional device)
4021
cef5f57bb9e2 [xemacs-hg @ 2007-06-21 13:39:08 by aidan]
aidan
parents: 3918
diff changeset
553 (x-find-xft-font-of-size font #'(lambda (old-size) (+ old-size 1.0)) device))
3094
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
554
ad2f4ae9895b [xemacs-hg @ 2005-11-26 11:45:47 by stephent]
stephent
parents: 2703
diff changeset
555 (defun x-find-larger-font-core (font &optional device)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
556 (x-frob-font-size font t device))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
557
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
558 (defalias 'x-make-face-bold 'make-face-bold)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
559 (defalias 'x-make-face-italic 'make-face-italic)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
560 (defalias 'x-make-face-bold-italic 'make-face-bold-italic)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
561 (defalias 'x-make-face-unbold 'make-face-unbold)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
562 (defalias 'x-make-face-unitalic 'make-face-unitalic)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
563
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
564 (make-obsolete 'x-make-face-bold 'make-face-bold)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
565 (make-obsolete 'x-make-face-italic 'make-face-italic)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
566 (make-obsolete 'x-make-face-bold-italic 'make-face-bold-italic)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
567 (make-obsolete 'x-make-face-unbold 'make-face-unbold)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
568 (make-obsolete 'x-make-face-unitalic 'make-face-unitalic)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
569
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
570
2527
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
571
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
572 ;; #### - wrong place for this variable? Exactly. We probably want
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
573 ;; `color-list' to be a console method, so `tty-color-list' becomes
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
574 ;; obsolete, and `read-color-completion-table' conses (mapcar #'list
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
575 ;; (color-list)), optionally caching the results.
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
576
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
577 ;; Ben wanted all of the possibilities from the `configure' script used
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
578 ;; here, but I think this is way too many. I already trimmed the R4 variants
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
579 ;; and a few obvious losers from the list. --Stig
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
580 (defvar x-library-search-path '("/usr/X11R6/lib/X11/"
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
581 "/usr/X11R5/lib/X11/"
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
582 "/usr/lib/X11R6/X11/"
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
583 "/usr/lib/X11R5/X11/"
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
584 "/usr/local/X11R6/lib/X11/"
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
585 "/usr/local/X11R5/lib/X11/"
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
586 "/usr/local/lib/X11R6/X11/"
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
587 "/usr/local/lib/X11R5/X11/"
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
588 "/usr/X11/lib/X11/"
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
589 "/usr/lib/X11/"
3125
d97bc868eaaf [xemacs-hg @ 2005-12-05 09:43:36 by scop]
scop
parents: 3094
diff changeset
590 "/usr/share/X11/"
2527
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
591 "/usr/local/lib/X11/"
3125
d97bc868eaaf [xemacs-hg @ 2005-12-05 09:43:36 by scop]
scop
parents: 3094
diff changeset
592 "/usr/local/share/X11/"
2527
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
593 "/usr/X386/lib/X11/"
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
594 "/usr/x386/lib/X11/"
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
595 "/usr/XFree86/lib/X11/"
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
596 "/usr/unsupported/lib/X11/"
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
597 "/usr/athena/lib/X11/"
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
598 "/usr/local/x11r5/lib/X11/"
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
599 "/usr/lpp/Xamples/lib/X11/"
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
600 "/usr/openwin/lib/X11/"
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
601 "/usr/openwin/share/lib/X11/")
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
602 "Search path used by `x-color-list-internal' to find rgb.txt.")
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
603
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
604 (defvar x-color-list-internal-cache)
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
605
4215
de99c4dbad18 [xemacs-hg @ 2007-10-07 06:54:59 by stephent]
stephent
parents: 4194
diff changeset
606 ;; Ben originally coded this in 2005/01 to return a list of lists each
de99c4dbad18 [xemacs-hg @ 2007-10-07 06:54:59 by stephent]
stephent
parents: 4194
diff changeset
607 ;; containing a single string. This is apparently derived from use of
de99c4dbad18 [xemacs-hg @ 2007-10-07 06:54:59 by stephent]
stephent
parents: 4194
diff changeset
608 ;; this list in completion, but in fact `read-color-completion-table'
de99c4dbad18 [xemacs-hg @ 2007-10-07 06:54:59 by stephent]
stephent
parents: 4194
diff changeset
609 ;; already does this wrapping. So I'm changing this to return a list of
de99c4dbad18 [xemacs-hg @ 2007-10-07 06:54:59 by stephent]
stephent
parents: 4194
diff changeset
610 ;; strings as the TTY code does, and as expected by r-c-c-t.
de99c4dbad18 [xemacs-hg @ 2007-10-07 06:54:59 by stephent]
stephent
parents: 4194
diff changeset
611 ;; -- sjt 2007-10-06
de99c4dbad18 [xemacs-hg @ 2007-10-07 06:54:59 by stephent]
stephent
parents: 4194
diff changeset
612
de99c4dbad18 [xemacs-hg @ 2007-10-07 06:54:59 by stephent]
stephent
parents: 4194
diff changeset
613 ;; This function is probably also used by the GTK platform. Cf.
5176
8b2f75cecb89 rename objects* (.c, .h and .el files) to fontcolor*
Ben Wing <ben@xemacs.org>
parents: 4822
diff changeset
614 ;; gtk_color_list in src/fontcolor-gtk.c.
2527
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
615 (defun x-color-list-internal ()
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
616 (if (boundp 'x-color-list-internal-cache)
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
617 x-color-list-internal-cache
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
618 (let ((rgb-file (locate-file "rgb.txt" x-library-search-path))
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
619 clist color p)
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
620 (if (not rgb-file)
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
621 ;; prevents multiple searches for rgb.txt if we can't find it
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
622 (setq x-color-list-internal-cache nil)
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
623 (with-current-buffer (get-buffer-create " *colors*")
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
624 (reset-buffer (current-buffer))
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
625 (insert-file-contents rgb-file)
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
626 (while (not (eobp))
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
627 ;; skip over comments
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
628 (while (looking-at "^!")
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
629 (end-of-line)
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
630 (forward-char 1))
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
631 (skip-chars-forward "0-9 \t")
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
632 (setq p (point))
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
633 (end-of-line)
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
634 (setq color (buffer-substring p (point))
4215
de99c4dbad18 [xemacs-hg @ 2007-10-07 06:54:59 by stephent]
stephent
parents: 4194
diff changeset
635 clist (cons color clist))
2527
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
636 ;; Ugh. If we want to be able to complete the lowercase form
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
637 ;; of the color name, we need to add it twice! Yuck.
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
638 (let ((dcase (downcase color)))
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
639 (or (string= dcase color)
4215
de99c4dbad18 [xemacs-hg @ 2007-10-07 06:54:59 by stephent]
stephent
parents: 4194
diff changeset
640 (push dcase clist)))
2527
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
641 (forward-char 1))
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
642 (kill-buffer (current-buffer))))
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
643 (setq x-color-list-internal-cache clist)
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
644 x-color-list-internal-cache)))
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
645
491f8cf78a9c [xemacs-hg @ 2005-01-28 02:58:38 by ben]
ben
parents: 872
diff changeset
646
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
647 ;;; internal routines
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
648
4822
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
649 ;;; x-init-face-from-resources is responsible for initializing a newly-created
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
650 ;;; face from the resource database.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
651 ;;;
4822
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
652 ;;; When a new frame is created, it is called from `x-init-frame-faces' called
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
653 ;;; from `init-frame-faces' called from init_frame_faces() from Fmake_frame().
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
654 ;;; In this case it is called once for each existing face, with the
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
655 ;;; newly-created frame as the argument. It then initializes the newly-created
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
656 ;;; faces on that frame.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
657 ;;;
4822
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
658 ;;; It's also called from `init-device-faces' and `init-global-faces'.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
659 ;;;
4822
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
660 ;;; This had better not signal an error. The frame is in an intermediate state
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
661 ;;; where signalling an error or entering the debugger would likely result in
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
662 ;;; a crash.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
663
4822
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
664 ;; When we initialise a face from an X resource, note that we did so. Now in
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
665 ;; specifier.el so run-time checks for it on non-X builds don't error.
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
666 ;; (define-specifier-tag 'x-resource)
3918
049dc907c17a [xemacs-hg @ 2007-04-22 19:58:27 by aidan]
aidan
parents: 3747
diff changeset
667
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
668 (defun x-init-face-from-resources (face &optional locale set-anyway)
4822
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
669 ;; These are things like "attributeForeground" instead of simply
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
670 ;; "foreground" because people tend to do things like "*foreground", which
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
671 ;; would cause all faces to be fully qualified, making faces inherit
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
672 ;; attributes in a non-useful way. So we've made them slightly less obvious
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
673 ;; to specify in order to make them work correctly in more random
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
674 ;; environments.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
675
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
676 ;; I think these should be called "face.faceForeground" instead of
4822
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
677 ;; "face.attributeForeground", but they're the way they are for hysterical
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
678 ;; reasons. (jwz)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
679 (let* ((append (if set-anyway nil 'append))
4822
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
680 ;; Some faces are initialized before XEmacs is dumped. In order for
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
681 ;; the X resources to be able to override those settings, such
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
682 ;; initialization always uses the `default' tag. We remove all
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
683 ;; specifier specs containing the `default' tag in the locale before
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
684 ;; adding new specs.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
685 (tag-set '(default))
4822
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
686 ;; The tag order matters here. The spec removal function uses the
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
687 ;; list cdrs. We want to remove (x default) and (default) specs, not
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
688 ;; (default x) and (x) specs.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
689 (x-tag-set '(x default))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
690 (tty-tag-set '(tty default))
3918
049dc907c17a [xemacs-hg @ 2007-04-22 19:58:27 by aidan]
aidan
parents: 3747
diff changeset
691 (our-tag-set '(x x-resource))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
692 (device-class nil)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
693 (face-sym (face-name face))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
694 (name (symbol-name face-sym))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
695 (fn (x-get-resource-and-maybe-bogosity-check
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
696 (concat name ".attributeFont")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
697 "Face.AttributeFont"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
698 'string locale))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
699 (fg (x-get-resource-and-maybe-bogosity-check
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
700 (concat name ".attributeForeground")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
701 "Face.AttributeForeground"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
702 'string locale))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
703 (bg (x-get-resource-and-maybe-bogosity-check
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
704 (concat name ".attributeBackground")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
705 "Face.AttributeBackground"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
706 'string locale))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
707 (bgp (x-get-resource-and-maybe-bogosity-check
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
708 (concat name ".attributeBackgroundPixmap")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
709 "Face.AttributeBackgroundPixmap"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
710 'string locale))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
711 (ulp (x-get-resource-and-maybe-bogosity-check
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
712 (concat name ".attributeUnderline")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
713 "Face.AttributeUnderline"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
714 'boolean locale))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
715 (stp (x-get-resource-and-maybe-bogosity-check
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
716 (concat name ".attributeStrikethru")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
717 "Face.AttributeStrikethru"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
718 'boolean locale))
4822
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
719 ;; we still resource for these TTY-only resources so that you can
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
720 ;; specify resources for TTY frames/devices. This is useful when you
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
721 ;; start up your XEmacs on an X display and later open some TTY
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
722 ;; frames.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
723 (hp (x-get-resource-and-maybe-bogosity-check
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
724 (concat name ".attributeHighlight")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
725 "Face.AttributeHighlight"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
726 'boolean locale))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
727 (dp (x-get-resource-and-maybe-bogosity-check
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
728 (concat name ".attributeDim")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
729 "Face.AttributeDim"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
730 'boolean locale))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
731 (bp (x-get-resource-and-maybe-bogosity-check
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
732 (concat name ".attributeBlinking")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
733 "Face.AttributeBlinking"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
734 'boolean locale))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
735 (rp (x-get-resource-and-maybe-bogosity-check
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
736 (concat name ".attributeReverse")
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
737 "Face.AttributeReverse"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
738 'boolean locale))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
739 )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
740
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
741 (cond ((framep locale)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
742 (setq device-class (device-class (frame-device locale))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
743 ((devicep locale)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
744 (setq device-class (device-class locale))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
745
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
746 (if device-class
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
747 (setq tag-set (cons device-class tag-set)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
748 x-tag-set (cons device-class x-tag-set)
3918
049dc907c17a [xemacs-hg @ 2007-04-22 19:58:27 by aidan]
aidan
parents: 3747
diff changeset
749 tty-tag-set (cons device-class tty-tag-set)
049dc907c17a [xemacs-hg @ 2007-04-22 19:58:27 by aidan]
aidan
parents: 3747
diff changeset
750 our-tag-set (cons device-class our-tag-set)))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
751
4822
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
752 ;; For the default and gui-element faces, some unspecified properties
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
753 ;; should be defaulted from the global properties. Can't do this for
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
754 ;; frames or devices because then, common resource specs like
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
755 ;; "*Foreground: black" will have unwanted effects.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
756 (if (and (or (eq (face-name face) 'default)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
757 (eq (face-name face) 'gui-element))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
758 (or (null locale) (eq locale 'global)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
759 (progn
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
760 (or fn (setq fn (x-get-resource
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
761 "font" "Font" 'string locale nil 'warn)))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
762 (or fg (setq fg (x-get-resource
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
763 "foreground" "Foreground" 'string locale nil
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
764 'warn)))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
765 (or bg (setq bg (x-get-resource
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
766 "background" "Background" 'string locale nil
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
767 'warn)))))
4822
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
768
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
769 ;; "*cursorColor: foo" is equivalent to setting the background of the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
770 ;; text-cursor face.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
771 (if (and (eq (face-name face) 'text-cursor)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
772 (or (null locale) (eq locale 'global)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
773 (setq bg (or (x-get-resource
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
774 "cursorColor" "CursorColor" 'string locale nil 'warn)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
775 bg)))
4822
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
776 ;; #### NOTE: should issue warnings? I think this should be done when the
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
777 ;; instancing actually happens, but I'm not sure how it should actually be
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
778 ;; dealt with.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
779 (when fn
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
780 (if device-class
4822
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
781 ;; Always use the x-tag-set to remove specs, since we don't know
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
782 ;; whether the predumped face was initialized with an 'x tag or not.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
783 (remove-specifier-specs-matching-tag-set-cdrs (face-font face)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
784 locale
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
785 x-tag-set)
4822
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
786 ;; If there's no device class then we're initializing globally. This
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
787 ;; means we should override global defaults for all X device classes.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
788 (remove-specifier (face-font face) locale x-tag-set nil))
3918
049dc907c17a [xemacs-hg @ 2007-04-22 19:58:27 by aidan]
aidan
parents: 3747
diff changeset
789 (set-face-font face fn locale our-tag-set append)
049dc907c17a [xemacs-hg @ 2007-04-22 19:58:27 by aidan]
aidan
parents: 3747
diff changeset
790
4822
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
791 ;; And retain some of the fallbacks in the generated default face, since
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
792 ;; we don't want to try andale-mono's ISO-10646-1 encoding for Amharic
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
793 ;; or Thai.
3918
049dc907c17a [xemacs-hg @ 2007-04-22 19:58:27 by aidan]
aidan
parents: 3747
diff changeset
794 (when (and (specifierp (face-font face))
049dc907c17a [xemacs-hg @ 2007-04-22 19:58:27 by aidan]
aidan
parents: 3747
diff changeset
795 (consp (specifier-fallback (face-font face))))
049dc907c17a [xemacs-hg @ 2007-04-22 19:58:27 by aidan]
aidan
parents: 3747
diff changeset
796 (loop
049dc907c17a [xemacs-hg @ 2007-04-22 19:58:27 by aidan]
aidan
parents: 3747
diff changeset
797 for (tag-set . instantiator)
049dc907c17a [xemacs-hg @ 2007-04-22 19:58:27 by aidan]
aidan
parents: 3747
diff changeset
798 in (specifier-fallback (face-font face))
049dc907c17a [xemacs-hg @ 2007-04-22 19:58:27 by aidan]
aidan
parents: 3747
diff changeset
799 if (memq 'x-coverage-instantiator tag-set)
049dc907c17a [xemacs-hg @ 2007-04-22 19:58:27 by aidan]
aidan
parents: 3747
diff changeset
800 do (add-spec-list-to-specifier
049dc907c17a [xemacs-hg @ 2007-04-22 19:58:27 by aidan]
aidan
parents: 3747
diff changeset
801 (face-font face)
049dc907c17a [xemacs-hg @ 2007-04-22 19:58:27 by aidan]
aidan
parents: 3747
diff changeset
802 (list (cons (or locale 'global)
049dc907c17a [xemacs-hg @ 2007-04-22 19:58:27 by aidan]
aidan
parents: 3747
diff changeset
803 (list (cons tag-set instantiator))))
049dc907c17a [xemacs-hg @ 2007-04-22 19:58:27 by aidan]
aidan
parents: 3747
diff changeset
804 append))))
3659
98af8a976fc3 [xemacs-hg @ 2006-11-05 22:31:31 by aidan]
aidan
parents: 3360
diff changeset
805
4822
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
806 ;; Kludge-o-rooni. Set the foreground and background resources for X
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
807 ;; devices only -- otherwise things tend to get all messed up if you start
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
808 ;; up an X frame and then later create a TTY frame.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
809 (when fg
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
810 (if device-class
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
811 (remove-specifier-specs-matching-tag-set-cdrs (face-foreground face)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
812 locale
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
813 x-tag-set)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
814 (remove-specifier (face-foreground face) locale x-tag-set nil))
3918
049dc907c17a [xemacs-hg @ 2007-04-22 19:58:27 by aidan]
aidan
parents: 3747
diff changeset
815 (set-face-foreground face fg locale our-tag-set append))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
816 (when bg
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
817 (if device-class
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
818 (remove-specifier-specs-matching-tag-set-cdrs (face-background face)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
819 locale
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
820 x-tag-set)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
821 (remove-specifier (face-background face) locale x-tag-set nil))
3918
049dc907c17a [xemacs-hg @ 2007-04-22 19:58:27 by aidan]
aidan
parents: 3747
diff changeset
822 (set-face-background face bg locale our-tag-set append))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
823 (when bgp
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
824 (if device-class
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
825 (remove-specifier-specs-matching-tag-set-cdrs (face-background-pixmap
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
826 face)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
827 locale
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
828 x-tag-set)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
829 (remove-specifier (face-background-pixmap face) locale x-tag-set nil))
3918
049dc907c17a [xemacs-hg @ 2007-04-22 19:58:27 by aidan]
aidan
parents: 3747
diff changeset
830 (set-face-background-pixmap face bgp locale our-tag-set append))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
831 (when ulp
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
832 (if device-class
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
833 (remove-specifier-specs-matching-tag-set-cdrs (face-property
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
834 face 'underline)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
835 locale
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
836 tty-tag-set)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
837 (remove-specifier (face-property face 'underline) locale
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
838 tty-tag-set nil))
3918
049dc907c17a [xemacs-hg @ 2007-04-22 19:58:27 by aidan]
aidan
parents: 3747
diff changeset
839 (set-face-underline-p face ulp locale our-tag-set append))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
840 (when stp
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
841 (if device-class
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
842 (remove-specifier-specs-matching-tag-set-cdrs (face-property
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
843 face 'strikethru)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
844 locale
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
845 tty-tag-set)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
846 (remove-specifier (face-property face 'strikethru)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
847 locale tty-tag-set nil))
3918
049dc907c17a [xemacs-hg @ 2007-04-22 19:58:27 by aidan]
aidan
parents: 3747
diff changeset
848 (set-face-strikethru-p face stp locale our-tag-set append))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
849 (when hp
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
850 (if device-class
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
851 (remove-specifier-specs-matching-tag-set-cdrs (face-property
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
852 face 'highlight)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
853 locale
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
854 tty-tag-set)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
855 (remove-specifier (face-property face 'highlight)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
856 locale tty-tag-set nil))
3918
049dc907c17a [xemacs-hg @ 2007-04-22 19:58:27 by aidan]
aidan
parents: 3747
diff changeset
857 (set-face-highlight-p face hp locale our-tag-set append))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
858 (when dp
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
859 (if device-class
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
860 (remove-specifier-specs-matching-tag-set-cdrs (face-property
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
861 face 'dim)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
862 locale
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
863 tty-tag-set)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
864 (remove-specifier (face-property face 'dim) locale tty-tag-set nil))
3918
049dc907c17a [xemacs-hg @ 2007-04-22 19:58:27 by aidan]
aidan
parents: 3747
diff changeset
865 (set-face-dim-p face dp locale our-tag-set append))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
866 (when bp
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
867 (if device-class
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
868 (remove-specifier-specs-matching-tag-set-cdrs (face-property
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
869 face 'blinking)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
870 locale
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
871 tty-tag-set)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
872 (remove-specifier (face-property face 'blinking) locale
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
873 tty-tag-set nil))
3918
049dc907c17a [xemacs-hg @ 2007-04-22 19:58:27 by aidan]
aidan
parents: 3747
diff changeset
874 (set-face-blinking-p face bp locale our-tag-set append))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
875 (when rp
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
876 (if device-class
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
877 (remove-specifier-specs-matching-tag-set-cdrs (face-property
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
878 face 'reverse)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
879 locale
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
880 tty-tag-set)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
881 (remove-specifier (face-property face 'reverse) locale
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
882 tty-tag-set nil))
3918
049dc907c17a [xemacs-hg @ 2007-04-22 19:58:27 by aidan]
aidan
parents: 3747
diff changeset
883 (set-face-reverse-p face rp locale our-tag-set append))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
884 ))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
885
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
886 ;; GNU Emacs compatibility. (move to obsolete.el?)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
887 (defalias 'make-face-x-resource-internal 'x-init-face-from-resources)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
888
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
889 (defun remove-specifier-specs-matching-tag-set-cdrs (specifier locale tag-set)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
890 (while tag-set
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
891 (remove-specifier specifier locale tag-set t)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
892 (setq tag-set (cdr tag-set))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
893
4822
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
894 ;;; x-init-global-faces is responsible for ensuring that the default face has
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
895 ;;; some reasonable fallbacks if nothing else is specified.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
896 (defun x-init-global-faces ()
4819
49480d838d32 Deactivate obsolete x-face initialization cod
Didier Verna <didier@lrde.epita.fr>
parents: 4215
diff changeset
897 ;; #### NOTE: this code is probably an oldy: faces.c ensures that we have
49480d838d32 Deactivate obsolete x-face initialization cod
Didier Verna <didier@lrde.epita.fr>
parents: 4215
diff changeset
898 ;; working fallback values so there is no need to initialize anything here.
49480d838d32 Deactivate obsolete x-face initialization cod
Didier Verna <didier@lrde.epita.fr>
parents: 4215
diff changeset
899 ;; -- dvl
49480d838d32 Deactivate obsolete x-face initialization cod
Didier Verna <didier@lrde.epita.fr>
parents: 4215
diff changeset
900 ;; (or (face-foreground 'default 'global)
49480d838d32 Deactivate obsolete x-face initialization cod
Didier Verna <didier@lrde.epita.fr>
parents: 4215
diff changeset
901 ;; (set-face-foreground 'default "black" 'global '(x default)))
49480d838d32 Deactivate obsolete x-face initialization cod
Didier Verna <didier@lrde.epita.fr>
parents: 4215
diff changeset
902 ;; (or (face-background 'default 'global)
49480d838d32 Deactivate obsolete x-face initialization cod
Didier Verna <didier@lrde.epita.fr>
parents: 4215
diff changeset
903 ;; (set-face-background 'default "gray80" 'global '(x default))
49480d838d32 Deactivate obsolete x-face initialization cod
Didier Verna <didier@lrde.epita.fr>
parents: 4215
diff changeset
904 )
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
905
4822
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
906 ;;; x-init-device-faces is responsible for initializing default values for
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
907 ;;; faces on a newly created device.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
908 (defun x-init-device-faces (device)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
909 ;; If the "default" face didn't have a font specified, try to pick one.
4822
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
910
872
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 801
diff changeset
911 ;; (or
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 801
diff changeset
912 ;; (face-font-instance 'default device)
4822
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
913
872
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 801
diff changeset
914 ;; [[ No font specified in the resource database; try to cope. ]]
4822
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
915
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
916 ;; #### NOTE: In reality, this will never happen. The fallbacks will always
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
917 ;; be tried, and the last fallback is "*", which should get any font. No
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
918 ;; need to put the same checks here as in the fallbacks. These comments
872
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 801
diff changeset
919 ;; appear to be pre-19.12. --ben
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
920
872
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 801
diff changeset
921 ;; [[ At first I wanted to do this by just putting a font-spec in the
4822
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
922 ;; fallback resources passed to XtAppInitialize(), but that fails if there
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
923 ;; is an Emacs app-defaults file which doesn't specify a font: apparently
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
924 ;; the fallback resources are not consulted when there is an app-defaults
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
925 ;; file, which seems pretty bogus to me.
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
926
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
927 ;; We should also probably try "*xtDefaultFont", but I think that it might
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
928 ;; be legal to specify that as "xtDefaultFont:", that is, at top level,
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
929 ;; instead of "*xtDefaultFont:", that is, applicable to every application.
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
930 ;; `x-get-resource' can't handle that right now. Anyway, xtDefaultFont is
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
931 ;; probably variable-width.
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
932
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
933 ;; Some who have LucidaTypewriter think it's a better font than Courier, but
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
934 ;; it has the bug that there are no italic and bold italic versions. We
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
935 ;; could hair this code up to try and mix-and-match fonts to get a full
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
936 ;; complement, but really, why bother. It's just a default. ]]
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
937
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
938 ;; [[ We default to looking for iso8859 fonts. Using a wildcard for the
872
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 801
diff changeset
939 ;; encoding would be bad, because that can cause English speakers to get
4822
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
940 ;; Kanji fonts by default. It is safe to assume that people using a language
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
941 ;; other than English have both set $LANG, and have specified their `font'
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
942 ;; and `fontList' resources. In any event, it's better to err on the side of
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
943 ;; the English speaker in this case because they are much less likely to
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
944 ;; have encountered this problem, and are thus less likely to know what to
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
945 ;; do about it. ]]
872
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 801
diff changeset
946
4819
49480d838d32 Deactivate obsolete x-face initialization cod
Didier Verna <didier@lrde.epita.fr>
parents: 4215
diff changeset
947 ;; #### NOTE: this code is probably an oldy as well (as per Ben's comment
49480d838d32 Deactivate obsolete x-face initialization cod
Didier Verna <didier@lrde.epita.fr>
parents: 4215
diff changeset
948 ;; above): faces.c ensures that we have working fallback values so there is
49480d838d32 Deactivate obsolete x-face initialization cod
Didier Verna <didier@lrde.epita.fr>
parents: 4215
diff changeset
949 ;; no need to initialize anything here. -- dvl
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
950
4819
49480d838d32 Deactivate obsolete x-face initialization cod
Didier Verna <didier@lrde.epita.fr>
parents: 4215
diff changeset
951 ;; (let ((fg (face-foreground-instance 'default device))
49480d838d32 Deactivate obsolete x-face initialization cod
Didier Verna <didier@lrde.epita.fr>
parents: 4215
diff changeset
952 ;; (bg (face-background-instance 'default device)))
49480d838d32 Deactivate obsolete x-face initialization cod
Didier Verna <didier@lrde.epita.fr>
parents: 4215
diff changeset
953 ;; (if (not (and fg bg))
49480d838d32 Deactivate obsolete x-face initialization cod
Didier Verna <didier@lrde.epita.fr>
parents: 4215
diff changeset
954 ;; (if (or (and fg (equalp (color-instance-name fg) "white"))
49480d838d32 Deactivate obsolete x-face initialization cod
Didier Verna <didier@lrde.epita.fr>
parents: 4215
diff changeset
955 ;; (and bg (equalp (color-instance-name bg) "black")))
49480d838d32 Deactivate obsolete x-face initialization cod
Didier Verna <didier@lrde.epita.fr>
parents: 4215
diff changeset
956 ;; (progn
49480d838d32 Deactivate obsolete x-face initialization cod
Didier Verna <didier@lrde.epita.fr>
parents: 4215
diff changeset
957 ;; (or fg (set-face-foreground 'default "white" device))
49480d838d32 Deactivate obsolete x-face initialization cod
Didier Verna <didier@lrde.epita.fr>
parents: 4215
diff changeset
958 ;; (or bg (set-face-background 'default "black" device)))
49480d838d32 Deactivate obsolete x-face initialization cod
Didier Verna <didier@lrde.epita.fr>
parents: 4215
diff changeset
959 ;; (or fg (set-face-foreground 'default "white" device))
49480d838d32 Deactivate obsolete x-face initialization cod
Didier Verna <didier@lrde.epita.fr>
parents: 4215
diff changeset
960 ;; (or bg (set-face-background 'default "black" device)))))
49480d838d32 Deactivate obsolete x-face initialization cod
Didier Verna <didier@lrde.epita.fr>
parents: 4215
diff changeset
961
4822
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
962 ;; Don't look at reverseVideo now or initialize the modeline. This is done
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
963 ;; on a per-frame basis at the appropriate time.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
964
4822
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
965 ;; Now let's try to pick some reasonable defaults for a few other faces.
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
966 ;; This kind of stuff should normally go on the create-frame-hook, but this
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
967 ;; way we won't be in danger of the user screwing things up by not adding
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
968 ;; hooks in a safe way.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
969 (x-init-pointer-shape device) ; from x-mouse.el
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
970 )
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
971
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
972 ;;; This is called from `init-frame-faces', which is called from
4822
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
973 ;;; init_frame_faces() which is called from Fmake_frame(), to perform any
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
974 ;;; device-specific initialization.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
975 (defun x-init-frame-faces (frame)
4822
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
976 ;; The faces already got initialized (by init-frame-faces) from the resource
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
977 ;; database or global, non-frame faces. The default, bold, bold-italic, and
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
978 ;; italic faces (plus various other random faces) got set up then. But
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
979 ;; modeline didn't so that reverseVideo can be frame-specific.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
980
4822
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
981 ;; If reverseVideo was specified, swap the foreground and background of the
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
982 ;; default and modeline faces.
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
983 (cond ((car (x-get-resource "reverseVideo" "ReverseVideo" 'boolean frame
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 428
diff changeset
984 nil 'warn))
4819
49480d838d32 Deactivate obsolete x-face initialization cod
Didier Verna <didier@lrde.epita.fr>
parents: 4215
diff changeset
985 ;; #### NOTE: again, this is probably yet another oldy: faces.c
49480d838d32 Deactivate obsolete x-face initialization cod
Didier Verna <didier@lrde.epita.fr>
parents: 4215
diff changeset
986 ;; ensures sane fallbacks for the modeline face. Besides, this face
49480d838d32 Deactivate obsolete x-face initialization cod
Didier Verna <didier@lrde.epita.fr>
parents: 4215
diff changeset
987 ;; does not inherit from the default face, but from the gui-element
49480d838d32 Deactivate obsolete x-face initialization cod
Didier Verna <didier@lrde.epita.fr>
parents: 4215
diff changeset
988 ;; one.-- dvl
49480d838d32 Deactivate obsolete x-face initialization cod
Didier Verna <didier@lrde.epita.fr>
parents: 4215
diff changeset
989
49480d838d32 Deactivate obsolete x-face initialization cod
Didier Verna <didier@lrde.epita.fr>
parents: 4215
diff changeset
990 ;; (or (face-foreground 'modeline frame)
49480d838d32 Deactivate obsolete x-face initialization cod
Didier Verna <didier@lrde.epita.fr>
parents: 4215
diff changeset
991 ;; (set-face-foreground 'modeline
49480d838d32 Deactivate obsolete x-face initialization cod
Didier Verna <didier@lrde.epita.fr>
parents: 4215
diff changeset
992 ;; (face-foreground-instance 'default frame)
49480d838d32 Deactivate obsolete x-face initialization cod
Didier Verna <didier@lrde.epita.fr>
parents: 4215
diff changeset
993 ;; frame))
49480d838d32 Deactivate obsolete x-face initialization cod
Didier Verna <didier@lrde.epita.fr>
parents: 4215
diff changeset
994 ;; (or (face-background 'modeline frame)
49480d838d32 Deactivate obsolete x-face initialization cod
Didier Verna <didier@lrde.epita.fr>
parents: 4215
diff changeset
995 ;; (set-face-background 'modeline
49480d838d32 Deactivate obsolete x-face initialization cod
Didier Verna <didier@lrde.epita.fr>
parents: 4215
diff changeset
996 ;; (face-background-instance 'default frame)
49480d838d32 Deactivate obsolete x-face initialization cod
Didier Verna <didier@lrde.epita.fr>
parents: 4215
diff changeset
997 ;; frame))
49480d838d32 Deactivate obsolete x-face initialization cod
Didier Verna <didier@lrde.epita.fr>
parents: 4215
diff changeset
998
4822
0482cdb4e35d Cosmetic changes in x-faces.e
Didier Verna <didier@lrde.epita.fr>
parents: 4819
diff changeset
999 ;; Now invert both of them. If they end up looking the same,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1000 ;; make-frame-initial-faces will invert the modeline again later.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1001 (invert-face 'default frame)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1002 (invert-face 'modeline frame)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1003 )))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1004
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1005 ;;; x-faces.el ends here