cgit.sxemacs.org Git - sxemacs/blob - lisp/font.el

   1 ;;; font.el --- New font model
   2 ;; Author: wmperry
   3 ;; Created: 1997/09/05 15:44:37
   4 ;; Version: 1.52
   5 ;; Keywords: faces
   6
   7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8 ;;; Copyright (c) 1995, 1996 by William M. Perry (wmperry@cs.indiana.edu)
   9 ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
  10 ;;;
  11 ;;; This file is part of SXEmacs.
  12 ;;;
  13 ;; SXEmacs is free software: you can redistribute it and/or modify
  14 ;; it under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation, either version 3 of the License, or
  16 ;; (at your option) any later version.
  17
  18 ;; SXEmacs is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;; GNU General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  25 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  26 (require 'cus-face)
  27
  28 (globally-declare-fboundp
  29  '(x-list-fonts internal-facep fontsetp
  30                 get-font-info get-fontset-info font-color-rgb-components
  31                 font-rgb-color-p cancel-function-timers run-at-time
  32                 set-font-oblique-p set-font-italic-p set-font-bold-p
  33                 font-dropcaps-p font-bigcaps-p font-smallcaps-p font-blink-p
  34                 font-reverse-p font-strikethru-p font-linethrough-p
  35                 font-overline-p font-underline-p font-dim-p font-oblique-p
  36                 font-italic-p font-bold-p))
  37
  38 (globally-declare-boundp 'global-face-data)
  39
  40 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  41 ;;; The emacsen compatibility package - load it up before anything else
  42 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  43 (require 'cl)
  44
  45 (eval-and-compile
  46   (defvar device-fonts-cache)
  47   (condition-case ()
  48       (require 'custom)
  49     (error nil))
  50   (if (and (featurep 'custom) (fboundp 'custom-declare-variable))
  51       nil ;; We've got what we needed
  52     ;; We have the old custom-library, hack around it!
  53     (defmacro defgroup (&rest args)
  54       nil)
  55     (defmacro defcustom (var value doc &rest args)
  56       `(defvar ,var ,value ,doc))))
  57
  58 (if (not (fboundp 'try-font-name))
  59     (defun try-font-name (fontname &rest args)
  60       (case window-system
  61         ((x) (car-safe (x-list-fonts fontname)))
  62         (otherwise nil))))
  63
  64 (if (not (fboundp 'facep))
  65     (defun facep (face)
  66       "Return t if X is a face name or an internal face vector."
  67       (if (not window-system)
  68           nil                           ; FIXME if FSF ever does TTY faces
  69         (and (or (internal-facep face)
  70                  (and (symbolp face) (assq face global-face-data)))
  71              t))))
  72
  73 (if (not (fboundp 'set-face-property))
  74     (defun set-face-property (face property value &optional locale
  75                                    tag-set how-to-add)
  76       "Change a property of FACE."
  77       (and (symbolp face)
  78            (put face property value))))
  79
  80 (if (not (fboundp 'face-property))
  81     (defun face-property (face property &optional locale tag-set exact-p)
  82       "Return FACE's value of the given PROPERTY."
  83       (and (symbolp face) (get face property))))
  84
  85 (require 'disp-table)
  86
  87 (eval-and-compile
  88   (unless (fboundp #'<<)
  89     (fset #'<< #'lsh))
  90   (unless (fboundp #'&)
  91     (fset #'& #'logand))
  92   (unless (fboundp #'|)
  93     (fset #'| #'logior))
  94   (unless (fboundp #'~)
  95     (fset #'~ #'lognot))
  96   (unless (fboundp #'>>)
  97     (defun >> (value count)
  98       (<< value (- count)))))
  99
 100 \f
 101 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 102 ;;; Lots of variables / keywords for use later in the program
 103 ;;; Not much should need to be modified
 104 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 105 (defconst font-running-xemacs (string-match "XEmacs" (emacs-version))
 106   "Whether we are running in XEmacs or not.")
 107
 108 (defmacro define-font-keywords (&rest keys)
 109   `(eval-and-compile
 110      (let ((keywords (quote ,keys)))
 111        (while keywords
 112          (or (boundp (car keywords))
 113              (set (car keywords) (car keywords)))
 114          (setq keywords (cdr keywords))))))
 115
 116 (defconst font-window-system-mappings
 117   '((x         . (x-font-create-name x-font-create-object))
 118     (gtk       . (x-font-create-name x-font-create-object))
 119     (tty       . (tty-font-create-plist tty-font-create-object)))
 120   "An assoc list mapping device types to a list of translations.
 121
 122 The first function creates a font name from a font descriptor object.
 123 The second performs the reverse translation.")
 124
 125 (defconst x-font-weight-mappings
 126   '((:extra-light . "extralight")
 127     (:light       . "light")
 128     (:demi-light  . "demilight")
 129     (:demi        . "demi")
 130     (:book        . "book")
 131     (:medium      . "medium")
 132     (:normal      . "medium")
 133     (:demi-bold   . "demibold")
 134     (:bold        . "bold")
 135     (:extra-bold  . "extrabold"))
 136   "An assoc list mapping keywords to actual Xwindow specific strings
 137 for use in the 'weight' field of an X font string.")
 138
 139 (defconst font-possible-weights
 140   (mapcar 'car x-font-weight-mappings))
 141
 142 (defvar font-rgb-file nil
 143   "Where the RGB file was found.")
 144
 145 (defvar font-maximum-slippage "1pt"
 146   "How much a font is allowed to vary from the desired size.")
 147
 148 ;; Canonical (internal) sizes are in points.
 149 ;; Registry
 150 (define-font-keywords :family :style :size :registry :encoding)
 151
 152 (define-font-keywords
 153   :weight :extra-light :light :demi-light :medium :normal :demi-bold
 154   :bold :extra-bold)
 155
 156 (defvar font-style-keywords nil)
 157
 158 (defsubst set-font-family (fontobj family)
 159   (aset fontobj 1 family))
 160
 161 (defsubst set-font-weight (fontobj weight)
 162   (aset fontobj 3 weight))
 163
 164 (defsubst set-font-style (fontobj style)
 165   (aset fontobj 5 style))
 166
 167 (defsubst set-font-size (fontobj size)
 168   (aset fontobj 7 size))
 169
 170 (defsubst set-font-registry (fontobj reg)
 171   (aset fontobj 9 reg))
 172
 173 (defsubst set-font-encoding (fontobj enc)
 174   (aset fontobj 11 enc))
 175
 176 (defsubst font-family (fontobj)
 177   (aref fontobj 1))
 178
 179 (defsubst font-weight (fontobj)
 180   (aref fontobj 3))
 181
 182 (defsubst font-style (fontobj)
 183   (aref fontobj 5))
 184
 185 (defsubst font-size (fontobj)
 186   (aref fontobj 7))
 187
 188 (defsubst font-registry (fontobj)
 189   (aref fontobj 9))
 190
 191 (defsubst font-encoding (fontobj)
 192   (aref fontobj 11))
 193
 194 (eval-when-compile
 195   (defmacro define-new-mask (attr mask)
 196     `(progn
 197        (setq font-style-keywords
 198              (cons (cons (quote ,attr)
 199                          (cons
 200                           (quote ,(intern (format "set-font-%s-p" attr)))
 201                           (quote ,(intern (format "font-%s-p" attr)))))
 202                    font-style-keywords))
 203        (defconst ,(intern (format "font-%s-mask" attr)) (<< 1 ,mask)
 204          ,(format
 205            "Bitmask for whether a font is to be rendered in %s or not."
 206            attr))
 207        (defun ,(intern (format "font-%s-p" attr)) (fontobj)
 208          ,(format "Whether FONTOBJ will be renderd in `%s' or not." attr)
 209          (if (/= 0 (& (font-style fontobj)
 210                       ,(intern (format "font-%s-mask" attr))))
 211              t
 212            nil))
 213        (defun ,(intern (format "set-font-%s-p" attr)) (fontobj val)
 214          ,(format "Set whether FONTOBJ will be renderd in `%s' or not."
 215                   attr)
 216          (cond
 217           (val
 218            (set-font-style fontobj (| (font-style fontobj)
 219                                       ,(intern
 220                                         (format "font-%s-mask" attr)))))
 221           ((,(intern (format "font-%s-p" attr)) fontobj)
 222            (set-font-style fontobj (- (font-style fontobj)
 223                                       ,(intern
 224                                         (format "font-%s-mask" attr)))))))
 225        )))
 226
 227 (let ((mask 0))
 228   (define-new-mask bold        (setq mask (1+ mask)))
 229   (define-new-mask italic      (setq mask (1+ mask)))
 230   (define-new-mask oblique     (setq mask (1+ mask)))
 231   (define-new-mask dim         (setq mask (1+ mask)))
 232   (define-new-mask underline   (setq mask (1+ mask)))
 233   (define-new-mask overline    (setq mask (1+ mask)))
 234   (define-new-mask linethrough (setq mask (1+ mask)))
 235   (define-new-mask strikethru  (setq mask (1+ mask)))
 236   (define-new-mask reverse     (setq mask (1+ mask)))
 237   (define-new-mask blink       (setq mask (1+ mask)))
 238   (define-new-mask smallcaps   (setq mask (1+ mask)))
 239   (define-new-mask bigcaps     (setq mask (1+ mask)))
 240   (define-new-mask dropcaps    (setq mask (1+ mask))))
 241
 242 (defvar font-caps-display-table
 243   (let ((table (make-display-table))
 244         (i 0))
 245     ;; Standard ASCII characters
 246     (while (< i 26)
 247       (aset table (+ i ?a) (+ i ?A))
 248       (setq i (1+ i)))
 249     ;; Now ISO translations
 250     (setq i 224)
 251     (while (< i 247)                    ;; Agrave - Ouml
 252       (aset table i (- i 32))
 253       (setq i (1+ i)))
 254     (setq i 248)
 255     (while (< i 255)                    ;; Oslash - Thorn
 256       (aset table i (- i 32))
 257       (setq i (1+ i)))
 258     table))
 259 \f
 260 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 261 ;;; Utility functions
 262 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 263 (defsubst set-font-style-by-keywords (fontobj styles)
 264   (make-local-variable 'font-func)
 265   (declare (special font-func))
 266   (if (listp styles)
 267       (while styles
 268         (setq font-func (car-safe (cdr-safe (assq (car styles) font-style-keywords)))
 269               styles (cdr styles))
 270         (and (fboundp font-func) (funcall font-func fontobj t)))
 271     (setq font-func (car-safe (cdr-safe (assq styles font-style-keywords))))
 272     (and (fboundp font-func) (funcall font-func fontobj t))))
 273
 274 (defsubst font-properties-from-style (fontobj)
 275   (let (;(style (font-style fontobj))
 276         (todo font-style-keywords)
 277         type func retval)
 278     (while todo
 279       (setq func (cdr (cdr (car todo)))
 280             type (car (pop todo)))
 281       (if (funcall func fontobj)
 282           (setq retval (cons type retval))))
 283     retval))
 284
 285 (defun font-unique (list)
 286   (let ((retval)
 287         (cur))
 288     (while list
 289       (setq cur (car list)
 290             list (cdr list))
 291       (if (member cur retval)
 292           nil
 293         (setq retval (cons cur retval))))
 294     (nreverse retval)))
 295
 296 (defun font-higher-weight (w1 w2)
 297   (let ((index1 (length (memq w1 font-possible-weights)))
 298         (index2 (length (memq w2 font-possible-weights))))
 299     (cond
 300      ((<= index1 index2)
 301       (or w1 w2))
 302      ((not w2)
 303       w1)
 304      (t
 305       w2))))
 306
 307 (defun font-spatial-to-canonical (spec &optional device)
 308   "Convert SPEC (in inches, millimeters, points, picas, or pixels) into points.
 309
 310 Canonical sizes are in points.  If SPEC is null, nil is returned.  If SPEC is
 311 a number, it is interpreted as the desired point size and returned unchanged.
 312 Otherwise SPEC must be a string consisting of a number and an optional type.
 313 The type may be the strings \"px\", \"pix\", or \"pixel\" (pixels), \"pt\" or
 314 \"point\" (points), \"pa\" or \"pica\" (picas), \"in\" or \"inch\" (inches), \"cm\"
 315 (centimeters), or \"mm\" (millimeters).
 316
 317 1 in = 2.54 cm = 6 pa = 25.4 mm = 72 pt.  Pixel size is device-dependent."
 318   (cond
 319    ((numberp spec)
 320     spec)
 321    ((null spec)
 322     nil)
 323    (t
 324     (let ((num nil)
 325           (type nil)
 326           ;; If for any reason we get null for any of this, default
 327           ;; to 1024x768 resolution on a 17" screen
 328           (pix-width (float (or (device-pixel-width device) 1024)))
 329           (mm-width (float (or (device-mm-width device) 293)))
 330           (retval nil))
 331       (cond
 332        ;; the following string-match is broken, there will never be a
 333        ;; left operand detected
 334        ((string-match #r"^ *\([-+*/]\) *" spec) ; math!  whee!
 335         (let ((math-func (intern (match-string 1 spec)))
 336               (other (font-spatial-to-canonical
 337                       (substring spec (match-end 0) nil)))
 338               (default (font-spatial-to-canonical
 339                         (font-default-size-for-device device))))
 340           (if (fboundp math-func)
 341               (setq type "px"
 342                     spec (int-to-string (funcall math-func default other)))
 343             (setq type "px"
 344                   spec (int-to-string other)))))
 345        ((string-match "[^0-9.]+$" spec)
 346         (setq type (substring spec (match-beginning 0))
 347               spec (substring spec 0 (match-beginning 0))))
 348        (t
 349         (setq type "px"
 350               spec spec)))
 351       (setq num (string-to-number spec))
 352       (cond
 353        ((member type '("pixel" "px" "pix"))
 354         (setq retval (* num (/ pix-width mm-width) (/ 25.4 72.0))))
 355        ((member type '("point" "pt"))
 356         (setq retval num))
 357        ((member type '("pica" "pa"))
 358         (setq retval (* num 12.0)))
 359        ((member type '("inch" "in"))
 360         (setq retval (* num 72.0)))
 361        ((string= type "mm")
 362         (setq retval (* num (/ 72.0 25.4))))
 363        ((string= type "cm")
 364         (setq retval (* num 10 (/ 72.0 25.4))))
 365        (t
 366         (setq retval num))
 367        )
 368       retval))))
 369
 370 \f
 371 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 372 ;;; The main interface routines - constructors and accessor functions
 373 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 374 (defun make-font (&rest args)
 375   (vector :family
 376           (if (stringp (plist-get args :family))
 377               (list (plist-get args :family))
 378             (plist-get args :family))
 379           :weight
 380           (plist-get args :weight)
 381           :style
 382           (if (numberp (plist-get args :style))
 383               (plist-get args :style)
 384             0)
 385           :size
 386           (plist-get args :size)
 387           :registry
 388           (plist-get args :registry)
 389           :encoding
 390           (plist-get args :encoding)))
 391
 392 (defun font-create-name (fontobj &optional device)
 393   "Return a font name constructed from FONTOBJ, appropriate for DEVICE."
 394   (let* ((type (device-type device))
 395          (func (car (cdr-safe (assq type font-window-system-mappings)))))
 396     (and func (fboundp func) (funcall func fontobj device))))
 397
 398 ;;;###autoload
 399 (defun font-create-object (fontname &optional device)
 400   "Return a font descriptor object for FONTNAME, appropriate for DEVICE."
 401   (let* ((type (device-type device))
 402          (func (car (cdr (cdr-safe (assq type font-window-system-mappings))))))
 403     (and func (fboundp func) (funcall func fontname device))))
 404
 405 (defun font-combine-fonts-internal (fontobj-1 fontobj-2)
 406   (let ((retval (make-font))
 407         (size-1 (and (font-size fontobj-1)
 408                      (font-spatial-to-canonical (font-size fontobj-1))))
 409         (size-2 (and (font-size fontobj-2)
 410                      (font-spatial-to-canonical (font-size fontobj-2)))))
 411     (set-font-weight retval (font-higher-weight (font-weight fontobj-1)
 412                                                 (font-weight fontobj-2)))
 413     (set-font-family retval (font-unique (append (font-family fontobj-1)
 414                                                  (font-family fontobj-2))))
 415     (set-font-style retval (| (font-style fontobj-1) (font-style fontobj-2)))
 416     (set-font-registry retval (or (font-registry fontobj-1)
 417                                   (font-registry fontobj-2)))
 418     (set-font-encoding retval (or (font-encoding fontobj-1)
 419                                   (font-encoding fontobj-2)))
 420     (set-font-size retval (cond
 421                            ((and size-1 size-2 (>= size-2 size-1))
 422                             (font-size fontobj-2))
 423                            ((and size-1 size-2)
 424                             (font-size fontobj-1))
 425                            (size-1
 426                             (font-size fontobj-1))
 427                            (size-2
 428                             (font-size fontobj-2))
 429                            (t nil)))
 430
 431     retval))
 432
 433 (defun font-combine-fonts (&rest args)
 434   (cond
 435    ((null args)
 436     (error "Wrong number of arguments to font-combine-fonts"))
 437    ((= (length args) 1)
 438     (car args))
 439    (t
 440     (let ((retval (font-combine-fonts-internal (nth 0 args) (nth 1 args))))
 441       (setq args (cdr (cdr args)))
 442       (while args
 443         (setq retval (font-combine-fonts-internal retval (car args))
 444               args (cdr args)))
 445       retval))))
 446
 447 \f
 448 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 449 ;;; The window-system dependent code (TTY-style)
 450 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 451 (defun tty-font-create-object (fontname &optional device)
 452   "Return a font descriptor object for FONTNAME, appropriate for TTY devices."
 453   (make-font :size "12pt"))
 454
 455 (defun tty-font-create-plist (fontobj &optional device)
 456   "Return a font name constructed from FONTOBJ, appropriate for TTY devices."
 457   (list
 458    (cons 'underline (font-underline-p fontobj))
 459    (cons 'highlight (if (or (font-bold-p fontobj)
 460                             (memq (font-weight fontobj) '(:bold :demi-bold)))
 461                         t))
 462    (cons 'dim       (font-dim-p fontobj))
 463    (cons 'blinking  (font-blink-p fontobj))
 464    (cons 'reverse   (font-reverse-p fontobj))))
 465
 466 \f
 467 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 468 ;;; The window-system dependent code (X-style)
 469 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 470 (defvar font-x-font-regexp (or (and font-running-xemacs
 471                                     (boundp 'x-font-regexp)
 472                                     x-font-regexp)
 473  (let
 474      ((-                "[-?]")
 475       (foundry          "[^-]*")
 476       (family           "[^-]*")
 477       ;(weight          #r"\(bold\|demibold\|medium\|black\)")
 478       (weight\?         #r"\([^-]*\)")
 479       ;(slant           #r"\([ior]\)")
 480       (slant\?          #r"\([^-]?\)")
 481       (swidth           #r"\([^-]*\)")
 482       (adstyle          #r"\([^-]*\)")
 483       (pixelsize        #r"\(\*\|[0-9]+\)")
 484       (pointsize        #r"\(\*\|0\|[0-9][0-9]+\)")
 485       (resx             #r"\([*0]\|[0-9][0-9]+\)")
 486       (resy             #r"\([*0]\|[0-9][0-9]+\)")
 487       (spacing          "[cmp?*]")
 488       (avgwidth         #r"\(\*\|[0-9]+\)")
 489       (registry         "[^-]*")
 490       (encoding "[^-]+")
 491       )
 492    (concat #r"\`\*?[-?*]"
 493            foundry - family - weight\? - slant\? - swidth - adstyle -
 494            pixelsize - pointsize - resx - resy - spacing - avgwidth -
 495            registry - encoding "\\'"
 496            ))))
 497
 498 (defvar font-x-registry-and-encoding-regexp
 499   (or (and font-running-xemacs
 500            (boundp 'x-font-regexp-registry-and-encoding)
 501            (symbol-value 'x-font-regexp-registry-and-encoding))
 502       (let ((- "[-?]")
 503             (registry "[^-]*")
 504             (encoding "[^-]+"))
 505         (concat - "\\(" registry "\\)" - "\\(" encoding "\\)\\'"))))
 506
 507 (defvar font-x-family-mappings
 508   '(
 509     ("serif"        . ("new century schoolbook"
 510                        "utopia"
 511                        "charter"
 512                        "times"
 513                        "lucidabright"
 514                        "garamond"
 515                        "palatino"
 516                        "times new roman"
 517                        "baskerville"
 518                        "bookman"
 519                        "bodoni"
 520                        "computer modern"
 521                        "rockwell"
 522                        ))
 523     ("sans-serif"   . ("lucida"
 524                        "helvetica"
 525                        "gills-sans"
 526                        "avant-garde"
 527                        "univers"
 528                        "optima"))
 529     ("elfin"        . ("tymes"))
 530     ("monospace"    . ("courier"
 531                        "fixed"
 532                        "lucidatypewriter"
 533                        "clean"
 534                        "terminal"))
 535     ("cursive"      . ("sirene"
 536                        "zapf chancery"))
 537     )
 538   "A list of font family mappings on X devices.")
 539
 540 (defun x-font-create-object (fontname &optional device)
 541   "Return a font descriptor object for FONTNAME, appropriate for X devices."
 542   (let ((case-fold-search t))
 543     (if (or (not (stringp fontname))
 544             (not (string-match font-x-font-regexp fontname)))
 545         (make-font)
 546       (let ((family nil)
 547             ;(style nil)
 548             (size nil)
 549             (weight  (match-string 1 fontname))
 550             (slant   (match-string 2 fontname))
 551             (swidth  (match-string 3 fontname))
 552             (adstyle (match-string 4 fontname))
 553             (pxsize  (match-string 5 fontname))
 554             (ptsize  (match-string 6 fontname))
 555             (retval nil)
 556             (case-fold-search t)
 557             )
 558         (if (not (string-match x-font-regexp-foundry-and-family fontname))
 559             nil
 560           (setq family (list (downcase (match-string 1 fontname)))))
 561         (if (string= "*" weight)  (setq weight  nil))
 562         (if (string= "*" slant)   (setq slant   nil))
 563         (if (string= "*" swidth)  (setq swidth  nil))
 564         (if (string= "*" adstyle) (setq adstyle nil))
 565         (if (string= "*" pxsize)  (setq pxsize  nil))
 566         (if (string= "*" ptsize)  (setq ptsize  nil))
 567         (if ptsize (setq size (/ (string-to-int ptsize) 10)))
 568         (if (and (not size) pxsize) (setq size (concat pxsize "px")))
 569         (if weight (setq weight (intern-soft (concat ":" (downcase weight)))))
 570         (if (and adstyle (not (equal adstyle "")))
 571             (setq family (append family (list (downcase adstyle)))))
 572         (setq retval (make-font :family family
 573                                 :weight weight
 574                                 :size size))
 575         (set-font-bold-p retval (eq :bold weight))
 576         (cond
 577          ((null slant) nil)
 578          ((member slant '("i" "I"))
 579           (set-font-italic-p retval t))
 580          ((member slant '("o" "O"))
 581           (set-font-oblique-p retval t)))
 582         (when (string-match font-x-registry-and-encoding-regexp fontname)
 583           (set-font-registry retval (match-string 1 fontname))
 584           (set-font-encoding retval (match-string 2 fontname)))
 585         retval))))
 586
 587 (defun x-font-families-for-device (&optional device no-resetp)
 588   (ignore-errors (require 'x-font-menu))
 589   (or device (setq device (selected-device)))
 590   (if (boundp 'device-fonts-cache)
 591       (let ((menu (or (cdr-safe (assq device device-fonts-cache)))))
 592         (if (and (not menu) (not no-resetp))
 593             (progn
 594               (declare-fboundp (reset-device-font-menus device))
 595               (x-font-families-for-device device t))
 596           (let ((scaled (mapcar #'(lambda (x) (if x (aref x 0)))
 597                                 (aref menu 0)))
 598                 (normal (mapcar #'(lambda (x) (if x (aref x 0)))
 599                                 (aref menu 1))))
 600             (sort (font-unique (nconc scaled normal)) 'string-lessp))))
 601     (cons "monospace" (mapcar 'car font-x-family-mappings))))
 602
 603 (defvar font-default-cache nil)
 604
 605 ;;;###autoload
 606 (defun font-default-font-for-device (&optional device)
 607   (or device (setq device (selected-device)))
 608   (if font-running-xemacs
 609       (font-truename
 610        (make-font-specifier
 611         (face-font-name 'default device)))
 612     (let ((font (cdr-safe (assq 'font (frame-parameters device)))))
 613       (if (and (fboundp 'fontsetp) (fontsetp font))
 614           (aref (get-font-info (aref (cdr (get-fontset-info font)) 0)) 2)
 615         font))))
 616
 617 ;;;###autoload
 618 (defun font-default-object-for-device (&optional device)
 619   (let ((font (font-default-font-for-device device)))
 620     (or (cdr-safe (assoc font font-default-cache))
 621         (let ((object (font-create-object font)))
 622           (push (cons font object) font-default-cache)
 623           object))))
 624
 625 ;;;###autoload
 626 (defun font-default-family-for-device (&optional device)
 627   (font-family (font-default-object-for-device (or device (selected-device)))))
 628
 629 ;;;###autoload
 630 (defun font-default-registry-for-device (&optional device)
 631   (font-registry (font-default-object-for-device (or device (selected-device)))))
 632
 633 ;;;###autoload
 634 (defun font-default-encoding-for-device (&optional device)
 635   (font-encoding (font-default-object-for-device (or device (selected-device)))))
 636
 637 ;;;###autoload
 638 (defun font-default-size-for-device (&optional device)
 639   ;; face-height isn't the right thing (always 1 pixel too high?)
 640   ;; (if font-running-xemacs
 641   ;;    (format "%dpx" (face-height 'default device))
 642   (font-size (font-default-object-for-device (or device (selected-device)))))
 643
 644 (defun x-font-create-name (fontobj &optional device)
 645   "Return a font name constructed from FONTOBJ, appropriate for X devices."
 646   (if (and (not (or (font-family fontobj)
 647                     (font-weight fontobj)
 648                     (font-size fontobj)
 649                     (font-registry fontobj)
 650                     (font-encoding fontobj)))
 651            (= (font-style fontobj) 0))
 652       (face-font 'default)
 653     (or device (setq device (selected-device)))
 654     (let* ((default (font-default-object-for-device device))
 655            (family (or (font-family fontobj)
 656                        (font-family default)
 657                        (x-font-families-for-device device)))
 658            (weight (or (font-weight fontobj) :medium))
 659            ;(style (font-style fontobj))
 660            (size (or (if font-running-xemacs
 661                          (font-size fontobj))
 662                      (font-size default)))
 663            (registry (or (font-registry fontobj)
 664                          (font-registry default)
 665                          "*"))
 666            (encoding (or (font-encoding fontobj)
 667                          (font-encoding default)
 668                          "*")))
 669       (if (stringp family)
 670           (setq family (list family)))
 671       (setq weight (font-higher-weight weight
 672                                        (and (font-bold-p fontobj) :bold)))
 673       (if (stringp size)
 674           (setq size (truncate (font-spatial-to-canonical size device))))
 675       (setq weight (or (cdr-safe (assq weight x-font-weight-mappings)) "*"))
 676       (let ((done nil)                  ; Did we find a good font yet?
 677             (font-name nil)             ; font name we are currently checking
 678             (cur-family nil)            ; current family we are checking
 679             )
 680         (while (and family (not done))
 681           (setq cur-family (car family)
 682                 family (cdr family))
 683           (if (assoc cur-family font-x-family-mappings)
 684               ;; If the family name is an alias as defined by
 685               ;; font-x-family-mappings, then append those families
 686               ;; to the front of 'family' and continue in the loop.
 687               (setq family (append
 688                             (cdr-safe (assoc cur-family
 689                                              font-x-family-mappings))
 690                             family))
 691             ;; Not an alias for a list of fonts, so we just check it.
 692             ;; First, convert all '-' to spaces so that we don't screw up
 693             ;; the oh-so wonderful X font model.  Wheee.
 694             (let ((x (length cur-family)))
 695               (while (> x 0)
 696                 (if (= ?- (aref cur-family (1- x)))
 697                     (aset cur-family (1- x) ? ))
 698                 (setq x (1- x))))
 699             ;; We treat oblique and italic as equivalent.  Don't ask.
 700             (let ((slants '("o" "i")))
 701               (while (and slants (not done))
 702                 (setq font-name (format "-*-%s-%s-%s-*-*-*-%s-*-*-*-*-%s-%s"
 703                                         cur-family weight
 704                                         (if (or (font-italic-p fontobj)
 705                                                 (font-oblique-p fontobj))
 706                                             (car slants)
 707                                           "r")
 708                                         (if size
 709                                             (int-to-string (* 10 size)) "*")
 710                                         registry
 711                                         encoding
 712                                         )
 713                       slants (cdr slants)
 714                       done (try-font-name font-name device))))))
 715         (if done font-name)))))
 716
 717 \f
 718 ;;; Cache building code
 719 ;;;###autoload
 720 (defun x-font-build-cache (&optional device)
 721   (let ((hash-table (make-hash-table :test 'equal :size 15))
 722         (fonts (mapcar 'x-font-create-object
 723                        (x-list-fonts "-*-*-*-*-*-*-*-*-*-*-*-*-*-*")))
 724         (plist nil)
 725         (cur nil))
 726     (while fonts
 727       (setq cur (car fonts)
 728             fonts (cdr fonts)
 729             plist (cl-gethash (car (font-family cur)) hash-table))
 730       (if (not (memq (font-weight cur) (plist-get plist 'weights)))
 731           (setq plist (plist-put plist 'weights (cons (font-weight cur)
 732                                                       (plist-get plist 'weights)))))
 733       (if (not (member (font-size cur) (plist-get plist 'sizes)))
 734           (setq plist (plist-put plist 'sizes (cons (font-size cur)
 735                                                     (plist-get plist 'sizes)))))
 736       (if (and (font-oblique-p cur)
 737                (not (memq 'oblique (plist-get plist 'styles))))
 738           (setq plist (plist-put plist 'styles (cons 'oblique (plist-get plist 'styles)))))
 739       (if (and (font-italic-p cur)
 740                (not (memq 'italic (plist-get plist 'styles))))
 741           (setq plist (plist-put plist 'styles (cons 'italic (plist-get plist 'styles)))))
 742       (cl-puthash (car (font-family cur)) plist hash-table))
 743     hash-table))
 744
 745 \f
 746 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 747 ;;; Now overwrite the original copy of set-face-font with our own copy that
 748 ;;; can deal with either syntax.
 749 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 750 ;;; ###autoload
 751 (defun font-set-face-font (&optional face font &rest args)
 752   (cond
 753    ((and (vectorp font) (= (length font) 12))
 754     (let ((font-name (font-create-name font)))
 755       (set-face-property face 'font-specification font)
 756       (cond
 757        ((null font-name)                ; No matching font!
 758         nil)
 759        ((listp font-name)               ; For TTYs
 760         (let (cur)
 761           (while font-name
 762             (setq cur (car font-name)
 763                   font-name (cdr font-name))
 764             (apply 'set-face-property face (car cur) (cdr cur) args))))
 765        (font-running-xemacs
 766         (apply 'set-face-font face font-name args)
 767         (apply 'set-face-underline-p face (font-underline-p font) args)
 768         (if (and (or (font-smallcaps-p font) (font-bigcaps-p font))
 769                  (fboundp 'set-face-display-table))
 770             (apply 'set-face-display-table
 771                    face font-caps-display-table args))
 772         (apply 'set-face-property face 'strikethru (or
 773                                                     (font-linethrough-p font)
 774                                                     (font-strikethru-p font))
 775                args))
 776        (t
 777         (condition-case nil
 778             (apply 'set-face-font face font-name args)
 779           (error
 780            (let ((args (car-safe args)))
 781              (and (or (font-bold-p font)
 782                       (memq (font-weight font) '(:bold :demi-bold)))
 783                   (make-face-bold face args t))
 784              (and (font-italic-p font) (make-face-italic face args t)))))
 785         (apply 'set-face-underline-p face (font-und