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