Mercurial > hg > xemacs-beta
annotate lisp/msw-faces.el @ 5773:94a6b8fbd56e
Use a face, show more context around open parenthesis, #'blink-matching-open
lisp/ChangeLog addition:
2013-12-17 Aidan Kehoe <kehoea@parhasard.net>
* simple.el (blink-matching-open):
When showing the opening parenthesis in the minibiffer, use the
isearch face for it, in case there are multiple parentheses in the
text shown.
When writing moderately involved macros, it's often not enough
just to show the backquote context before the parenthesis
(e.g. @,.`). Skip over that when searching for useful context in
the same way we skip over space and tab.
* simple.el (message):
* simple.el (lmessage):
If there are no ARGS, don't call #'format. This allows extent
information to be passed through to the minibuffer.
It's probably better still to update #'format to preserve extent
info.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Tue, 17 Dec 2013 20:49:52 +0200 |
| parents | 308d34e9f07d |
| children |
| rev | line source |
|---|---|
| 428 | 1 ;;; msw-faces.el --- mswindows-specific face stuff. |
| 2 | |
| 3 ;;; Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc. | |
| 793 | 4 ;;; Copyright (C) 1995, 1996, 2002 Ben Wing. |
| 428 | 5 |
| 6 ;; Author: Jamie Zawinski | |
| 7 ;; Modified by: Chuck Thompson | |
| 8 ;; Modified by: Ben Wing | |
| 9 ;; Modified by: Martin Buchholz | |
| 10 ;; Rewritten for mswindows by: Jonathan Harris | |
| 11 | |
| 12 ;; This file is part of XEmacs. | |
| 13 | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5267
diff
changeset
|
14 ;; XEmacs is free software: you can redistribute it and/or modify it |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5267
diff
changeset
|
15 ;; under the terms of the GNU General Public License as published by the |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5267
diff
changeset
|
16 ;; Free Software Foundation, either version 3 of the License, or (at your |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5267
diff
changeset
|
17 ;; option) any later version. |
| 428 | 18 |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5267
diff
changeset
|
19 ;; XEmacs is distributed in the hope that it will be useful, but WITHOUT |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5267
diff
changeset
|
20 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5267
diff
changeset
|
21 ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5267
diff
changeset
|
22 ;; for more details. |
| 428 | 23 |
| 24 ;; You should have received a copy of the GNU General Public License | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5267
diff
changeset
|
25 ;; along with XEmacs. If not, see <http://www.gnu.org/licenses/>. |
| 428 | 26 |
| 27 ;; This file does the magic to parse mswindows font names, and make sure that | |
| 28 ;; the default and modeline attributes of new frames are specified enough. | |
| 29 | |
| 1346 | 30 (globally-declare-boundp |
| 31 '(mswindows-font-regexp mswindows-font-regexp-missing-1 | |
| 32 mswindows-font-regexp-missing-2 mswindows-font-regexp-missing-3 | |
| 33 mswindows-font-regexp-missing-4)) | |
| 34 | |
| 853 | 35 (defun mswindows-init-global-faces () |
| 36 (set-face-font 'gui-element "MS Sans Serif:Regular:8" nil 'mswindows)) | |
| 793 | 37 |
| 428 | 38 (defun mswindows-init-device-faces (device) |
| 442 | 39 (let ((color-default (device-system-metric device 'color-default)) |
| 40 (color-3d-face (device-system-metric device 'color-3d-face))) | |
| 41 ; Force creation of the default face font so that if it fails we get | |
| 42 ; an error now instead of a crash at frame creation. | |
| 43 (unless (face-font-instance 'default device) | |
| 44 (error "Can't find a suitable default font")) | |
| 872 | 45 |
| 46 ;; Don't set them on the device because then the global setting won't | |
| 47 ;; override them. | |
| 48 ;; #### Use device tags if we have multiple msprinter devices. (can we?) | |
| 442 | 49 (if (car color-default) |
| 872 | 50 (set-face-foreground 'default (car color-default) nil |
| 51 (device-type device))) | |
| 442 | 52 (if (cdr color-default) |
| 872 | 53 (set-face-background 'default (cdr color-default) nil |
| 54 (device-type device))) | |
| 442 | 55 (if (car color-3d-face) |
| 872 | 56 (set-face-foreground 'gui-element (car color-3d-face) nil |
| 57 (device-type device))) | |
| 442 | 58 (if (cdr color-3d-face) |
| 872 | 59 (set-face-background 'gui-element (cdr color-3d-face) nil |
| 60 (device-type device))) | |
| 793 | 61 )) |
| 428 | 62 |
| 63 (defun mswindows-init-frame-faces (frame) | |
| 64 ) | |
| 65 | |
| 66 ;; Other functions expect these regexps | |
| 872 | 67 (let |
| 68 ((- ":") | |
| 4022 | 69 ;; What happens if a font family contains a colon? I can't find any |
| 70 ;; documentation on that, and don't have a font editor to hand to test. | |
| 71 (fontname "\\([^:]*\\)") ; 1 | |
| 872 | 72 (style "\\(\\(?:[a-zA-Z]+\\(?: +[a-zA-Z]+\\)*\\)?\\)") ; 2 |
| 73 (pointsize "\\([0-9]*\\)") ; 3 | |
| 74 (effects "\\(\\(?:[a-zA-Z]+\\(?: +[a-zA-Z]+\\)*\\)?\\)") ; 4 | |
| 75 ;; must match "OEM/DOS" | |
| 76 (charset "\\([a-zA-Z/ ]*\\)") ; 5 | |
| 77 ) | |
| 78 (defconst mswindows-font-regexp | |
| 79 (concat "^" fontname - style - pointsize - effects - charset "$")) | |
| 80 (defconst mswindows-font-regexp-missing-1 | |
| 81 (concat "^" fontname - style - pointsize - effects "$")) | |
| 82 (defconst mswindows-font-regexp-missing-2 | |
| 83 (concat "^" fontname - style - pointsize "$")) | |
| 84 (defconst mswindows-font-regexp-missing-3 | |
| 85 (concat "^" fontname - style "$")) | |
| 86 (defconst mswindows-font-regexp-missing-4 | |
| 87 (concat "^" fontname "$")) | |
| 88 ) | |
| 428 | 89 |
| 90 ;;; Fill in missing parts of a font spec. This is primarily intended as a | |
| 91 ;;; helper function for the functions below. | |
| 92 ;;; mswindows fonts look like: | |
| 872 | 93 ;;; fontname[:[weight][ slant][:pointsize[:effects]]][:charset] |
| 428 | 94 ;;; A minimal mswindows font spec looks like: |
| 95 ;;; Courier New | |
| 96 ;;; A maximal mswindows font spec looks like: | |
| 97 ;;; Courier New:Bold Italic:10:underline strikeout:Western | |
| 872 | 98 (defun mswindows-canonicalize-font-name (font) |
| 99 "Given a mswindows font or font name, return its name in canonical form. | |
| 100 This adds missing colons and fills in the style field with \"Regular\". | |
| 101 This does *NOT* fill in the point size or charset fields, because in those | |
| 102 cases an empty field is not equivalent to any particular field value, but a | |
| 103 wildcard allowing for any possible value (charset Western and point size 10 | |
| 104 are chosen first, if they exist)." | |
| 105 (if (font-instance-p font) (setq font (font-instance-name font))) | |
| 106 ;; fill in missing colons | |
| 107 (setq font | |
| 108 (cond ((string-match mswindows-font-regexp font) font) | |
| 109 ((string-match mswindows-font-regexp-missing-1 font) | |
| 110 (concat font ":")) | |
| 111 ((string-match mswindows-font-regexp-missing-2 font) | |
| 112 (concat font "::")) | |
| 113 ((string-match mswindows-font-regexp-missing-3 font) | |
| 114 (concat font ":::")) | |
| 115 ((string-match mswindows-font-regexp-missing-4 font) | |
| 116 (concat font "::::")) | |
| 117 (t "::::"))) | |
| 118 (or (string-match mswindows-font-regexp font) (error "can't parse %S" font)) | |
| 119 (if (equal "" (match-string 2 font)) | |
| 120 (concat (substring font 0 (match-beginning 2)) "Regular" | |
| 121 (substring font (match-beginning 2))) | |
| 122 font)) | |
| 123 | |
| 124 (defun mswindows-parse-font-style (style) | |
| 125 ;; Parse a style into a cons (WEIGHT . SLANT). WEIGHT will never be the | |
| 126 ;; empty string (it may be "Regular"), but SLANT will be empty for | |
| 127 ;; non-italic. | |
| 128 (save-match-data | |
| 129 (let ((case-fold-search t)) | |
| 130 (cond ((equalp style "Italic") '("Regular" . "Italic")) | |
| 131 ((string-match "^\\([a-zA-Z ]+?\\) +Italic$" style) | |
| 132 (cons (match-string 1 style) "Italic")) | |
| 133 (t (cons style "")))))) | |
| 134 | |
| 135 (defun mswindows-construct-font-style (weight slant) | |
| 136 ;; Construct the style from WEIGHT and SLANT. Opposite of | |
| 137 ;; mswindows-parse-font-style. | |
| 138 (cond ((and (equal slant "") (equal weight "")) "Regular") | |
| 139 ((equal slant "") weight) | |
| 140 ((or (equalp weight "Regular") (equal weight "")) slant) | |
| 141 (t (concat weight " " slant)))) | |
| 142 | |
| 143 (defun mswindows-frob-font-style (font which) | |
| 144 ;; Given a font name or font instance, return a name with the style field | |
| 145 ;; (which includes weight and/or slant) changed according to WHICH, a plist. | |
| 146 ;; If no entry found, don't change. | |
| 147 (if (null font) nil | |
| 148 (setq font (mswindows-canonicalize-font-name font)) | |
| 149 (or (string-match mswindows-font-regexp font) | |
| 150 (error "can't parse %S" font)) | |
| 151 (let* ((style (match-string 2 font)) | |
| 152 (style-rep | |
| 153 (save-match-data | |
| 154 (or (loop for (x y) on which by #'cddr | |
| 155 if (string-match (concat "^" x "$") style) | |
| 156 return (replace-match y nil nil style)) | |
| 157 style)))) | |
| 158 (concat (substring font 0 (match-beginning 2)) | |
| 159 style-rep | |
| 160 (substring font (match-end 2)))))) | |
| 161 | |
| 162 (defun mswindows-frob-font-style-and-sizify (font which &optional device) | |
| 163 (if (null font) nil | |
| 164 (let* ((oldwidth (if (font-instance-p font) (font-instance-width font) | |
| 165 (let ((fi (make-font-instance font device t))) | |
| 166 (and fi (font-instance-width fi))))) | |
| 167 (newname (mswindows-frob-font-style font which)) | |
| 168 (newfont (make-font-instance newname device t))) | |
| 169 ;; Hack! On MS Windows, bold fonts (even monospaced) are often wider | |
| 170 ;; than the equivalent non-bold font. Making the bold font one point | |
| 171 ;; smaller usually makes it the same width (maybe at the expense of | |
| 172 ;; making it one pixel shorter). Do the same trick in both directions. | |
| 173 (when (font-instance-p newfont) | |
| 174 (let ((newerfont newfont)) | |
| 175 (block nil | |
| 176 (while (and newerfont oldwidth) | |
| 177 (setq newfont newerfont) | |
| 178 (cond ((< (font-instance-width newfont) oldwidth) | |
| 179 (setq newerfont | |
| 180 (make-font-instance | |
| 181 (mswindows-find-larger-font newfont device) | |
| 182 device t)) | |
| 183 (if (and newerfont | |
| 184 (> (font-instance-width newerfont) oldwidth)) | |
| 185 (return nil))) | |
| 186 ((> (font-instance-width newfont) oldwidth) | |
| 187 (setq newerfont | |
| 188 (make-font-instance | |
| 189 (mswindows-find-smaller-font newfont device) | |
| 190 device t)) | |
| 191 (if (and newerfont | |
| 192 (< (font-instance-width newerfont) oldwidth)) | |
| 193 (return nil))) | |
| 194 (t (return nil)))))) | |
| 195 (if (font-instance-p newfont) (font-instance-name newfont) newfont))))) | |
| 196 | |
| 197 (defconst mswindows-nonbold-weight-regexp | |
| 198 ;; He looked so, so cool with the ultra light dangling from his mouth as | |
| 199 ;; his fingers spun out demisemiquavers from the keyboard ... | |
| 200 "\\(Regular\\|Thin\\|Extra Light\\|Ultra Light\\|Light\\|Normal\\|Medium\\|Semi Bold\\|Demi Bold\\)" | |
| 201 ) | |
| 202 (defconst mswindows-bold-weight-regexp | |
| 203 "\\(Semi Bold\\|Demi Bold\\|Bold\\|Extra Bold\\|Ultra Bold\\|Heavy\\|Black\\)" | |
| 204 ) | |
| 205 | |
| 206 (defconst mswindows-make-font-bold-mapper | |
| 207 `(,mswindows-nonbold-weight-regexp "Bold" | |
| 208 "Italic" "Bold Italic" | |
| 209 ,(concat mswindows-nonbold-weight-regexp " Italic") "Bold Italic")) | |
| 210 | |
| 211 (defconst mswindows-make-font-nonbold-mapper | |
| 212 `(,mswindows-bold-weight-regexp "Regular" | |
| 213 ,(concat mswindows-bold-weight-regexp " Italic") "Italic")) | |
| 214 | |
| 215 (defconst mswindows-make-font-italic-mapper | |
| 216 '("\\(.*\\)Italic" "\\1Italic" | |
| 217 "\\(.*\\)" "\\1 Italic")) | |
| 218 | |
| 219 (defconst mswindows-make-font-unitalic-mapper | |
| 220 '("Italic" "Regular" | |
| 221 "\\(.*\\) Italic" "\\1")) | |
| 222 | |
| 223 (defconst mswindows-make-font-bold-italic-mapper | |
| 224 `(,mswindows-nonbold-weight-regexp "Bold Italic" | |
| 225 ,(concat mswindows-nonbold-weight-regexp " Italic") "Bold Italic" | |
| 226 "Italic" "Bold Italic" | |
| 227 ,mswindows-bold-weight-regexp "\\1 Italic")) | |
| 428 | 228 |
| 229 (defun mswindows-make-font-bold (font &optional device) | |
| 230 "Given a mswindows font specification, this attempts to make a bold font. | |
| 231 If it fails, it returns nil." | |
| 872 | 232 (mswindows-frob-font-style-and-sizify font mswindows-make-font-bold-mapper |
| 233 device)) | |
| 428 | 234 |
| 235 (defun mswindows-make-font-unbold (font &optional device) | |
| 236 "Given a mswindows font specification, this attempts to make a non-bold font. | |
| 237 If it fails, it returns nil." | |
| 872 | 238 (mswindows-frob-font-style-and-sizify font mswindows-make-font-nonbold-mapper |
| 239 device)) | |
| 428 | 240 |
| 241 (defun mswindows-make-font-italic (font &optional device) | |
| 242 "Given a mswindows font specification, this attempts to make an `italic' | |
| 243 font. If it fails, it returns nil." | |
| 872 | 244 (try-font-name (mswindows-frob-font-style |
| 245 font mswindows-make-font-italic-mapper) device)) | |
| 428 | 246 |
| 247 (defun mswindows-make-font-unitalic (font &optional device) | |
| 248 "Given a mswindows font specification, this attempts to make a non-italic | |
| 249 font. If it fails, it returns nil." | |
| 872 | 250 (try-font-name (mswindows-frob-font-style |
| 251 font mswindows-make-font-unitalic-mapper) device)) | |
| 428 | 252 |
| 253 (defun mswindows-make-font-bold-italic (font &optional device) | |
| 254 "Given a mswindows font specification, this attempts to make a `bold-italic' | |
| 255 font. If it fails, it returns nil." | |
| 872 | 256 (mswindows-frob-font-style-and-sizify font |
| 257 mswindows-make-font-bold-italic-mapper | |
| 258 device)) | |
| 259 | |
| 260 (defun mswindows-available-font-sizes (font device) | |
| 261 (if (font-instance-p font) (setq font (font-instance-name font))) | |
| 262 (setq font (mswindows-canonicalize-font-name font)) | |
| 263 (or (string-match mswindows-font-regexp font) (error "Can't parse %S" font)) | |
| 264 ;; turn pointsize into wildcard | |
| 265 (setq font | |
| 266 (concat (substring font 0 (match-beginning 3)) | |
| 267 (substring font (match-end 3) (match-end 0)))) | |
| 268 (sort | |
|
5267
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
4022
diff
changeset
|
269 (mapcan #'(lambda (name) |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
4022
diff
changeset
|
270 (and (string-match mswindows-font-regexp name) |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
4022
diff
changeset
|
271 (list (string-to-int (substring name (match-beginning 3) |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
4022
diff
changeset
|
272 (match-end 3)))))) |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
4022
diff
changeset
|
273 (font-list font device)) |
| 872 | 274 #'<)) |
| 275 | |
| 276 (defun mswindows-frob-font-size (font up-p device) | |
| 277 (if (stringp font) (setq font (make-font-instance font device))) | |
| 278 (let* ((name (font-instance-name font)) | |
| 279 (truename (font-instance-truename font)) | |
| 280 (available (and truename | |
| 281 (mswindows-available-font-sizes truename device)))) | |
| 282 (if (null available) nil | |
| 283 (or (string-match mswindows-font-regexp truename) | |
| 284 (error "can't parse %S" truename)) | |
| 285 (let ((old-size (string-to-int | |
| 286 (substring truename | |
| 287 (match-beginning 3) (match-end 3))))) | |
| 288 (or (> old-size 0) (error "font truename has 0 pointsize?")) | |
| 289 (or (string-match mswindows-font-regexp name) | |
| 290 (error "can't parse %S" name)) | |
| 291 (let ((newsize | |
| 292 ;; scalable fonts: change size by 1 point. | |
| 293 (if (= 0 (car available)) | |
| 294 (if (and (not up-p) (= 1 old-size)) nil | |
| 295 (if up-p (1+ old-size) (1- old-size))) | |
| 296 ;; non-scalable fonts: take the next available size. | |
| 297 (if up-p | |
| 298 (loop for tail on available | |
| 299 if (eql (car tail) old-size) | |
| 300 return (cadr tail)) | |
| 301 (loop for tail on available | |
| 302 if (eql (cadr tail) old-size) | |
| 303 return (car tail)))))) | |
| 304 (and newsize | |
| 305 (concat (substring name 0 (match-beginning 3)) | |
| 306 (int-to-string newsize) | |
| 307 (substring name (match-end 3) (match-end 0))))))))) | |
| 428 | 308 |
| 309 (defun mswindows-find-smaller-font (font &optional device) | |
| 310 "Loads a new version of the given font (or font name) 1 point smaller. | |
| 311 Returns the font if it succeeds, nil otherwise." | |
| 872 | 312 (mswindows-frob-font-size font nil device)) |
| 428 | 313 |
| 314 (defun mswindows-find-larger-font (font &optional device) | |
| 315 "Loads a new version of the given font (or font name) 1 point larger. | |
| 316 Returns the font if it succeeds, nil otherwise." | |
| 872 | 317 (mswindows-frob-font-size font t device)) |