home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / x11 / x-faces.el < prev    next >
Encoding:
Text File  |  1995-08-29  |  32.2 KB  |  771 lines
  1. ;;; x-faces.el --- X-specific face frobnication, aka black magic.
  2.  
  3. ;;; Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc.
  4. ;;; Copyright (C) 1995 Ben Wing.
  5.  
  6. ;; Author: Jamie Zawinski <jwz@lucid.com>
  7. ;; Modified by:  Chuck Thompson <cthomp@cs.uiuc.edu>
  8. ;; Modified by:  Ben Wing <wing@spg.amdahl.com>
  9.  
  10. ;; This file is part of XEmacs.
  11.  
  12. ;; XEmacs is free software; you can redistribute it and/or modify it
  13. ;; under the terms of the GNU General Public License as published by
  14. ;; the Free Software Foundation; either version 2, or (at your option)
  15. ;; any later version.
  16.  
  17. ;; XEmacs is distributed in the hope that it will be useful, but
  18. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  19. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  20. ;; General Public License for more details.
  21.  
  22. ;; You should have received a copy of the GNU General Public License
  23. ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  24. ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  25.  
  26. ;; This file does the magic to parse X font names, and make sure that the
  27. ;; default and modeline attributes of new frames are specified enough.
  28. ;;
  29. ;;  The resource-manager syntax for faces is
  30. ;;
  31. ;;     Emacs.bold.attributeFont:        font-name
  32. ;;     Emacs.bold.attributeForeground:    fg
  33. ;;     Emacs.bold.attributeBackground:    bg
  34. ;;     Emacs.bold.attributeBackgroundPixmap:    file
  35. ;;     Emacs.bold.attributeUnderline:        true/false
  36. ;;
  37. ;;  You can specify the parameters of a face on a per-frame basis.  For 
  38. ;;  example, to have the "isearch" face use a red foreground on frames
  39. ;;  named "emacs" (the default) but use a blue foreground on frames that
  40. ;;  you create named "debugger", you could do
  41. ;;
  42. ;;     Emacs*emacs.isearch.attributeForeground:    red
  43. ;;     Emacs*debugger.isearch.attributeForeground:    blue
  44. ;;
  45. ;;  Generally things that make faces won't set any of the face attributes if
  46. ;;  you have already given them values via the resource database.  You can
  47. ;;  also change this stuff from your .emacs file, by using the functions
  48. ;;  set-face-foreground, set-face-font, etc.  See the code in this file, and
  49. ;;  in faces.el.
  50.  
  51. (defconst x-font-regexp nil)
  52. (defconst x-font-regexp-head nil)
  53. (defconst x-font-regexp-head-2 nil)
  54. (defconst x-font-regexp-weight nil)
  55. (defconst x-font-regexp-slant nil)
  56. (defconst x-font-regexp-pixel nil)
  57. (defconst x-font-regexp-point nil)
  58. (defconst x-font-regexp-foundry-and-family nil)
  59. (defconst x-font-regexp-registry-and-encoding nil)
  60. (defconst x-font-regexp-spacing nil)
  61.  
  62. ;;; Regexps matching font names in "Host Portable Character Representation."
  63. ;;;
  64. (let ((-         "[-?]")
  65.       (foundry        "[^-]*")
  66.       (family         "[^-]*")
  67.       (weight        "\\(bold\\|demibold\\|medium\\|black\\)")    ; 1
  68. ;     (weight\?        "\\(\\*\\|bold\\|demibold\\|medium\\|\\)")    ; 1
  69.       (weight\?        "\\([^-]*\\)")                    ; 1
  70.       (slant        "\\([ior]\\)")                    ; 2
  71. ;     (slant\?        "\\([ior?*]?\\)")                ; 2
  72.       (slant\?        "\\([^-]?\\)")                    ; 2
  73. ;     (swidth        "\\(\\*\\|normal\\|semicondensed\\|\\)")    ; 3
  74.       (swidth        "\\([^-]*\\)")                    ; 3
  75. ;     (adstyle        "\\(\\*\\|sans\\|\\)")                ; 4
  76.       (adstyle        "\\([^-]*\\)")                    ; 4
  77.       (pixelsize    "\\(\\*\\|[0-9]+\\)")                ; 5
  78.       (pointsize    "\\(\\*\\|0\\|[0-9][0-9]+\\)")            ; 6
  79. ;      (resx        "\\(\\*\\|[0-9][0-9]+\\)")            ; 7
  80. ;      (resy        "\\(\\*\\|[0-9][0-9]+\\)")            ; 8
  81.       (resx        "\\([*0]\\|[0-9][0-9]+\\)")            ; 7
  82.       (resy        "\\([*0]\\|[0-9][0-9]+\\)")            ; 8
  83.       (spacing        "[cmp?*]")
  84.       (avgwidth        "\\(\\*\\|[0-9]+\\)")                ; 9
  85.       (registry        "[^-]*") ; some fonts have omitted registries
  86. ;      (encoding    ".+")        ; note that encoding may contain "-"...
  87.       (encoding    "[^-]+")        ; false!
  88.       )
  89.   (setq x-font-regexp
  90.     (purecopy 
  91.      (concat "\\`\\*?[-?*]"
  92.          foundry - family - weight\? - slant\? - swidth - adstyle -
  93.          pixelsize - pointsize - resx - resy - spacing - avgwidth -
  94.          registry - encoding "\\'"
  95.          )))
  96.   (setq x-font-regexp-head
  97.     (purecopy
  98.           (concat "\\`[-?*]" foundry - family - weight\? - slant\?
  99.           "\\([-*?]\\|\\'\\)")))
  100.   (setq x-font-regexp-head-2
  101.     (purecopy
  102.           (concat "\\`[-?*]" foundry - family - weight\? - slant\?
  103.           - swidth - adstyle - pixelsize - pointsize
  104.           "\\([-*?]\\|\\'\\)")))
  105.   (setq x-font-regexp-slant (purecopy (concat - slant -)))
  106.   (setq x-font-regexp-weight (purecopy (concat - weight -)))
  107.   ;; if we can't match any of the more specific regexps (unfortunate) then
  108.   ;; look for digits; assume 2+ digits is 10ths of points, and 1-2 digits
  109.   ;; is pixels.  Bogus as hell.
  110.   (setq x-font-regexp-pixel (purecopy "[-?*]\\([0-9][0-9]?\\)[-?*]"))
  111.   (setq x-font-regexp-point (purecopy "[-?*]\\([0-9][0-9]+\\)[-?*]"))
  112.   ;; the following two are used by x-font-menu.el.
  113.   (setq x-font-regexp-foundry-and-family
  114.     (purecopy (concat "\\`[-?*]" foundry - "\\(" family "\\)" -)))
  115.   (setq x-font-regexp-registry-and-encoding
  116.     (purecopy (concat - "\\(" registry "\\)" - "\\(" encoding "\\)\\'")))
  117.   (setq x-font-regexp-spacing
  118.     (purecopy (concat - "\\(" spacing "\\)" - avgwidth
  119.               - registry - encoding "\\'")))
  120.   )
  121.  
  122. ;; A "loser font" is something like "8x13" -> "8x13bold".
  123. ;; These are supported only through extreme generosity.
  124. (defconst x-loser-font-regexp (purecopy "\\`[0-9]+x[0-9]+\\'"))
  125.  
  126. (defun x-frob-font-weight (font which)
  127.   (if (font-instance-p font) (setq font (font-instance-name font)))
  128.   (cond ((null font) nil)
  129.     ((or (string-match x-font-regexp font)
  130.          (string-match x-font-regexp-head font)
  131.          (string-match x-font-regexp-weight font))
  132.      (concat (substring font 0 (match-beginning 1)) which
  133.          (substring font (match-end 1))))
  134.     ((string-match x-loser-font-regexp font)
  135.      (concat font which))
  136.     (t nil)))
  137.  
  138. (defun x-frob-font-slant (font which)
  139.   (if (font-instance-p font) (setq font (font-instance-name font)))
  140.   (cond ((null font) nil)
  141.     ((or (string-match x-font-regexp font)
  142.          (string-match x-font-regexp-head font))
  143.      (concat (substring font 0 (match-beginning 2)) which
  144.          (substring font (match-end 2))))
  145.     ((string-match x-font-regexp-slant font)
  146.      (concat (substring font 0 (match-beginning 1)) which
  147.          (substring font (match-end 1))))
  148.     ((string-match x-loser-font-regexp font)
  149.      (concat font which))
  150.     (t nil)))
  151.  
  152. (defun try-font-name (name &optional device)
  153.   ;; yes, name really should be here twice.
  154.   (and name (make-font-instance name device t) name))
  155.  
  156. (defun x-make-font-bold (font &optional device)
  157.   "Given an X font specification, this attempts to make a `bold' font.
  158. If it fails, it returns nil."
  159.   ;; Certain Type1 fonts know "bold" as "black"...
  160.   (or (try-font-name (x-frob-font-weight font "bold") device)
  161.       (try-font-name (x-frob-font-weight font "black") device)
  162.       (try-font-name (x-frob-font-weight font "demibold") device)))
  163.  
  164. (defun x-make-font-unbold (font &optional device)
  165.   "Given an X font specification, this attempts to make a non-bold font.
  166. If it fails, it returns nil."
  167.   (try-font-name (x-frob-font-weight font "medium") device))
  168.  
  169. (defun x-make-font-italic (font &optional device)
  170.   "Given an X font specification, this attempts to make an `italic' font.
  171. If it fails, it returns nil."
  172.   (or (try-font-name (x-frob-font-slant font "i") device)
  173.       (try-font-name (x-frob-font-slant font "o") device)))
  174.  
  175. (defun x-make-font-unitalic (font &optional device)
  176.   "Given an X font specification, this attempts to make a non-italic font.
  177. If it fails, it returns nil."
  178.   (try-font-name (x-frob-font-slant font "r") device))
  179.  
  180. (defun x-make-font-bold-italic (font &optional device)
  181.   "Given an X font specification, this attempts to make a `bold-italic' font.
  182. If it fails, it returns nil."
  183.   ;; This is haired up to avoid loading the "intermediate" fonts.
  184.   (or (try-font-name
  185.        (x-frob-font-slant (x-frob-font-weight font "bold") "i") device)
  186.       (try-font-name
  187.        (x-frob-font-slant (x-frob-font-weight font "bold") "o") device)
  188.       (try-font-name
  189.        (x-frob-font-slant (x-frob-font-weight font "black") "i") device)
  190.       (try-font-name
  191.        (x-frob-font-slant (x-frob-font-weight font "black") "o") device)
  192.       (try-font-name
  193.        (x-frob-font-slant (x-frob-font-weight font "demibold") "i") device)
  194.       (try-font-name
  195.        (x-frob-font-slant (x-frob-font-weight font "demibold") "o") device)))
  196.  
  197. (defun x-font-size (font)
  198.   "Return the nominal size of the given font.
  199. This is done by parsing its name, so it's likely to lose.
  200. X fonts can be specified (by the user) in either pixels or 10ths of points,
  201.  and this returns the first one it finds, so you have to decide which units
  202.  the returned value is measured in yourself..."
  203.   (if (font-instance-p font) (setq font (font-instance-name font)))
  204.   (cond ((or (string-match x-font-regexp font)
  205.          (string-match x-font-regexp-head-2 font))
  206.      (string-to-int (substring font (match-beginning 6) (match-end 6))))
  207.     ((or (string-match x-font-regexp-pixel font)
  208.          (string-match x-font-regexp-point font))
  209.      (string-to-int (substring font (match-beginning 1) (match-end 1))))
  210.     (t nil)))
  211.  
  212. ;; Given a font name, this function returns a list describing all fonts
  213. ;; of all sizes that otherwise match the given font spec.  Each element
  214. ;; in the list is a list of three items: the pixel size of the font,
  215. ;; the point size (in 1/10ths of a point) of the font, and the fully-
  216. ;; qualified font name.  The first two values may be zero; this
  217. ;; refers to a scalable font.
  218.  
  219. (defun x-available-font-sizes (font device)
  220.   (if (font-instance-p font) (setq font (font-instance-name font)))
  221.   (cond ((string-match x-font-regexp font)
  222.      ;; turn pixelsize, pointsize, and avgwidth into wildcards
  223.      (setq font
  224.            (concat (substring font 0 (match-beginning 5)) "*"
  225.                (substring font (match-end 5) (match-beginning 6)) "*"
  226.                (substring font (match-end 6) (match-beginning 9)) "*"
  227.                (substring font (match-end 9) (match-end 0)))))
  228.     ((string-match x-font-regexp-head-2 font)
  229.      ;; turn pixelsize and pointsize into wildcards
  230.      (setq font
  231.            (concat (substring font 0 (match-beginning 5)) "*"
  232.                (substring font (match-end 5) (match-beginning 6)) "*"
  233.                (substring font (match-end 6) (match-end 0)))))
  234.     ((string-match  "[-?*]\\([0-9]+\\)[-?*]" font)
  235.      ;; Turn the first integer we match into a wildcard.
  236.      ;; This is pretty dubious...
  237.      (setq font
  238.            (concat (substring font 0 (match-beginning 1)) "*"
  239.                (substring font (match-end 1) (match-end 0))))))
  240.   (sort
  241.    (delq nil
  242.      (mapcar (function
  243.           (lambda (name)
  244.             (and (string-match x-font-regexp name)
  245.              (list
  246.               (string-to-int (substring name (match-beginning 5)
  247.                             (match-end 5)))
  248.               (string-to-int (substring name (match-beginning 6)
  249.                             (match-end 6)))
  250.               name))))
  251.          (list-fonts font device)))
  252.    (function (lambda (x y) (if (= (nth 1 x) (nth 1 y))
  253.                    (< (nth 0 x) (nth 0 y))
  254.                    (< (nth 1 x) (nth 1 y)))))))
  255.  
  256. ;; Given a font name, this attempts to construct a valid font name for
  257. ;; DEVICE whose size is the next smaller (if UP-P is nil) or larger
  258. ;; (if UP-P is t) size and whose other characteristics are the same
  259. ;; as the given font.
  260.  
  261. (defun x-frob-font-size (font up-p device)
  262.   (if (stringp font) (setq font (make-font-instance font device)))
  263.   (if (font-instance-p font) (setq font (font-instance-truename font)))
  264.   (let ((available (and font
  265.             (x-available-font-sizes font device))))
  266.     (cond
  267.      ((null available) nil)
  268.      ((or (= 0 (nth 0 (car available)))
  269.       (= 0 (nth 1 (car available))))
  270.       ;; R5 scalable fonts: change size by 1 point.
  271.       ;; If they're scalable the first font will have pixel or point = 0.
  272.       ;; Sometimes one is 0 and the other isn't (if it's a bitmap font that
  273.       ;; can be scaled), sometimes both are (if it's a true outline font).
  274.       (let ((name (nth 2 (car available)))
  275.         old-size)
  276.     (or (string-match x-font-regexp font) (error "can't parse %S" font))
  277.     (setq old-size (string-to-int
  278.             (substring font (match-beginning 6) (match-end 6))))
  279.     (or (> old-size 0) (error "font truename has 0 pointsize?"))
  280.     (or (string-match x-font-regexp name) (error "can't parse %S" name))
  281.     ;; turn pixelsize into a wildcard, and make pointsize be +/- 10,
  282.     ;; which is +/- 1 point.  All other fields stay the same as they
  283.     ;; were in the "template" font returned by x-available-font-sizes.
  284.     ;;
  285.     ;; #### But this might return the same font: for example, if the
  286.     ;;      truename of "-*-courier-medium-r-normal--*-230-75-75-m-0-*"
  287.     ;;      is "...-240-..." (instead of 230) then this loses, because
  288.     ;;      the 230 that was passed in as an arg got turned into 240
  289.     ;;      by the call to font-instance-truename; then we decrement that
  290.     ;;    by 10 and return the result which is the same.  I think the
  291.     ;;    way to fix this is to make this be a loop that keeps trying
  292.     ;;      progressively larger pointsize deltas until it finds one
  293.     ;;      whose truename differs.  Have to be careful to avoid infinite
  294.     ;;      loops at the upper end...
  295.     ;;
  296.     (concat (substring name 0 (match-beginning 5)) "*"
  297.         (substring name (match-end 5) (match-beginning 6))
  298.         (int-to-string (+ old-size (if up-p 10 -10)))
  299.         (substring name (match-end 6) (match-end 0)))))
  300.      (t
  301.       ;; non-scalable fonts: take the next available size.
  302.       (let ((rest available)
  303.         (last nil)
  304.         result)
  305.     (setq font (downcase font))
  306.     (while rest
  307.       (cond ((and (not up-p) (equal font (downcase (nth 2 (car rest)))))
  308.          (setq result last
  309.                rest nil))
  310.         ((and up-p (equal font (and last (downcase (nth 2 last)))))
  311.          (setq result (car rest)
  312.                rest nil)))
  313.       (setq last (car rest))
  314.       (setq rest (cdr rest)))
  315.     (nth 2 result))))))
  316.  
  317. (defun x-find-smaller-font (font &optional device)
  318.   "Loads a new, slightly smaller version of the given font (or font name).
  319. Returns the font if it succeeds, nil otherwise.
  320. If scalable fonts are available, this returns a font which is 1 point smaller.
  321. Otherwise, it returns the next smaller version of this font that is defined."
  322.   (x-frob-font-size font nil device))
  323.  
  324. (defun x-find-larger-font (font &optional device)
  325.   "Loads a new, slightly larger version of the given font (or font name).
  326. Returns the font if it succeeds, nil otherwise.
  327. If scalable fonts are available, this returns a font which is 1 point larger.
  328. Otherwise, it returns the next larger version of this font that is defined."
  329.   (x-frob-font-size font t device))
  330.  
  331. (defalias 'x-make-face-bold 'make-face-bold)
  332. (defalias 'x-make-face-italic 'make-face-italic)
  333. (defalias 'x-make-face-bold-italic 'make-face-bold-italic)
  334. (defalias 'x-make-face-unbold 'make-face-unbold)
  335. (defalias 'x-make-face-unitalic 'make-face-unitalic)
  336.  
  337. (make-obsolete 'x-make-face-bold 'make-face-bold)
  338. (make-obsolete 'x-make-face-italic 'make-face-italic)
  339. (make-obsolete 'x-make-face-bold-italic 'make-face-bold-italic)
  340. (make-obsolete 'x-make-face-unbold 'make-face-unbold)
  341. (make-obsolete 'x-make-face-unitalic 'make-face-unitalic)
  342.  
  343.  
  344. ;; Define some logical color names to be used when reading the pixmap files.
  345. (if (featurep 'xpm)
  346.     (setq xpm-color-symbols
  347.       (list
  348.        (purecopy '("foreground" (face-foreground 'default)))
  349.        (purecopy '("background" (face-background 'default)))
  350.        (purecopy '("backgroundToolBarColor"
  351.                (x-get-resource "backgroundToolBarColor"
  352.                        "BackgroundToolBarColor" 'string)))
  353.        )))
  354.  
  355. ;;; internal routines
  356.  
  357. ;;; x-init-face-from-resources is responsible for initializing a
  358. ;;; newly-created face from the resource database.
  359. ;;;
  360. ;;; When a new frame is created, it is called from `x-init-frame-faces'
  361. ;;; called from `init-frame-faces' called from init_frame_faces()
  362. ;;; from Fmake_frame().  In this case it is called once for each existing
  363. ;;; face, with the newly-created frame as the argument.  It then initializes
  364. ;;; the newly-created faces on that frame.
  365. ;;;
  366. ;;; It's also called from `init-device-faces' and
  367. ;;; `init-global-faces'.
  368. ;;;
  369. ;;; This had better not signal an error.  The frame is in an intermediate
  370. ;;; state where signalling an error or entering the debugger would likely
  371. ;;; result in a crash.
  372.  
  373. (defun x-init-face-from-resources (face locale)
  374.   ;;
  375.   ;; These are things like "attributeForeground" instead of simply
  376.   ;; "foreground" because people tend to do things like "*foreground",
  377.   ;; which would cause all faces to be fully qualified, making faces
  378.   ;; inherit attributes in a non-useful way.  So we've made them slightly
  379.   ;; less obvious to specify in order to make them work correctly in
  380.   ;; more random environments.
  381.   ;;
  382.   ;; I think these should be called "face.faceForeground" instead of
  383.   ;; "face.attributeForeground", but they're the way they are for
  384.   ;; hysterical reasons. (jwz)
  385.  
  386.   (let* ((face-sym (face-name face))
  387.      (name (symbol-name face-sym))
  388.      (fn (x-get-resource-and-maybe-bogosity-check
  389.           (concat name ".attributeFont")
  390.           "Face.AttributeFont"
  391.           'string locale))
  392.      (fg (x-get-resource-and-maybe-bogosity-check
  393.           (concat name ".attributeForeground")
  394.           "Face.AttributeForeground"
  395.           'string locale))
  396.      (bg (x-get-resource-and-maybe-bogosity-check
  397.           (concat name ".attributeBackground")
  398.           "Face.AttributeBackground"
  399.           'string locale))
  400.      (bgp (x-get-resource-and-maybe-bogosity-check
  401.            (concat name ".attributeBackgroundPixmap")
  402.            "Face.AttributeBackgroundPixmap"
  403.            'string locale))
  404.      (ulp (x-get-resource-and-maybe-bogosity-check
  405.            (concat name ".attributeUnderline")
  406.            "Face.AttributeUnderline"
  407.            'boolean locale))
  408.      ;; we still resource for these TTY-only resources so that
  409.      ;; you can specify resources for TTY frames/devices.  This is
  410.      ;; useful when you start up your XEmacs on an X display and later
  411.      ;; open some TTY frames.
  412.      (hp (x-get-resource-and-maybe-bogosity-check
  413.           (concat name ".attributeHighlight")
  414.           "Face.AttributeHighlight"
  415.           'boolean locale))
  416.      (dp (x-get-resource-and-maybe-bogosity-check
  417.           (concat name ".attributeDim")
  418.           "Face.AttributeDim"
  419.           'boolean locale))
  420.      (bp (x-get-resource-and-maybe-bogosity-check
  421.           (concat name ".attributeBlinking")
  422.           "Face.AttributeBlinking"
  423.           'boolean locale))
  424.      (rp (x-get-resource-and-maybe-bogosity-check
  425.           (concat name ".attributeReverse")
  426.           "Face.AttributeReverse"
  427.           'boolean locale))
  428.      )
  429.  
  430.     ;;
  431.     ;; If this is the default face, then any unspecified parameters should
  432.     ;; be defaulted from the global properties.  Can't do this for
  433.     ;; frames or devices because then, common resource specs like
  434.     ;; "*Foreground: black" will have unwanted effects.
  435.     ;;
  436.     (if (and (eq (face-name face) 'default)
  437.          (or (null locale) (eq locale 'global)))
  438.     (progn
  439.       (or fn (setq fn (x-get-resource
  440.                "font" "Font" 'string locale)))
  441.       (or fg (setq fg (x-get-resource
  442.                "foreground" "Foreground" 'string locale)))
  443.       (or bg (setq bg (x-get-resource
  444.                "background" "Background" 'string locale)))))
  445.     ;; #### should issue warnings?  I think this should be
  446.     ;; done when the instancing actually happens, but I'm not
  447.     ;; sure how it should actually be dealt with.
  448.     (if fn
  449.     (set-face-font face fn locale nil 'append))
  450.     (if fg
  451.     (set-face-foreground face fg locale nil 'append))
  452.     (if bg
  453.     (set-face-background face bg locale nil 'append))
  454.     (if bgp
  455.     (set-face-background-pixmap face bgp locale nil 'append))
  456.     (if ulp
  457.     (set-face-underline-p face ulp locale nil 'append))
  458.     (if hp
  459.     (set-face-highlight-p face hp locale nil 'append))
  460.     (if dp
  461.     (set-face-dim-p face dp locale nil 'append))
  462.     (if bp
  463.     (set-face-blinking-p face bp locale nil 'append))
  464.     (if rp
  465.     (set-face-reverse-p face rp locale nil 'append))
  466.     ))
  467.  
  468. ;;; x-init-global-faces is responsible for ensuring that the
  469. ;;; default face has some reasonable fallbacks if nothing else is
  470. ;;; specified.
  471. ;;;
  472. (defun x-init-global-faces ()
  473.   (or (face-font 'default 'global)
  474.       (set-face-font 'default
  475.              "-*-courier-medium-r-*-*-*-120-*-*-*-*-iso8859-*")
  476.       'global)
  477.   (or (face-foreground 'default 'global)
  478.       (set-face-foreground 'default "black" 'global))
  479.   (or (face-background 'default 'global)
  480.       (set-face-background 'default "white" 'global)))
  481.  
  482. ;;; x-init-device-faces is responsible for initializing default
  483. ;;; values for faces on a newly created device.
  484. ;;;
  485. (defun x-init-device-faces (device)
  486.   ;;
  487.   ;; If the "default" face didn't have a font specified, try to pick one.
  488.   ;;
  489.   (or
  490.    (face-font-instance 'default device)
  491.    ;;
  492.    ;; No font specified in the resource database; try to cope.
  493.    ;;
  494.    ;; At first I wanted to do this by just putting a font-spec in the
  495.    ;; fallback resources passed to XtAppInitialize(), but that fails
  496.    ;; if there is an Emacs app-defaults file which doesn't specify a
  497.    ;; font: apparently the fallback resources are not consulted when
  498.    ;; there is an app-defaults file, which seems pretty bogus to me.
  499.    ;;
  500.    ;; We should also probably try "*xtDefaultFont", but I think that it
  501.    ;; might be legal to specify that as "xtDefaultFont:", that is, at
  502.    ;; top level, instead of "*xtDefaultFont:", that is, applicable to
  503.    ;; every application.  `x-get-resource' can't handle that right now.
  504.    ;; Anyway, xtDefaultFont is probably variable-width.
  505.    ;;
  506.    ;; Some who have LucidaTypewriter think it's a better font than Courier,
  507.    ;; but it has the bug that there are no italic and bold italic versions.
  508.    ;; We could hair this code up to try and mix-and-match fonts to get a
  509.    ;; full complement, but really, why bother.  It's just a default.
  510.    ;;
  511.    (let (new-x-font)
  512.      (setq new-x-font (or
  513.       ;;
  514.       ;; We default to looking for iso8859 fonts.  Using a wildcard for the
  515.       ;; encoding would be bad, because that can cause English speakers to get
  516.       ;; Kanji fonts by default.  It is safe to assume that people using a
  517.       ;; language other than English have both set $LANG, and have specified
  518.       ;; their `font' and `fontList' resources.  In any event, it's better to
  519.       ;; err on the side of the English speaker in this case because they are
  520.       ;; much less likely to have encountered this problem, and are thus less
  521.       ;; likely to know what to do about it.
  522.  
  523.       ;; Try for Courier.  Almost everyone has that.  (Does anyone not?)
  524.       (make-font-instance
  525.        "-*-courier-medium-r-*-*-*-120-*-*-*-*-iso8859-*" device t)
  526.       (make-font-instance
  527.        "-*-courier-*-r-*-*-*-120-*-*-*-*-iso8859-*" device t)
  528.       ;; Next try for any "medium" charcell or monospaced iso8859 font.
  529.       (make-font-instance "-*-*-medium-r-*-*-*-120-*-*-m-*-iso8859-*" device t)
  530.       (make-font-instance "-*-*-medium-r-*-*-*-120-*-*-c-*-iso8859-*" device t)
  531.       ;; Next try for any charcell or monospaced iso8859 font.
  532.       (make-font-instance "-*-*-*-r-*-*-*-120-*-*-m-*-iso8859-*" device t)
  533.       (make-font-instance "-*-*-*-r-*-*-*-120-*-*-c-*-iso8859-*" device t)
  534.       ;; Ok, let's at least try to stay in 8859...
  535.       (make-font-instance "-*-*-*-r-*-*-*-120-*-*-*-*-iso8859-*" device t)
  536.       ;; Boy, we sure are losing now.  Try the above, but in any encoding.
  537.       (make-font-instance "-*-*-medium-r-*-*-*-120-*-*-m-*-*-*" device t)
  538.       (make-font-instance "-*-*-medium-r-*-*-*-120-*-*-c-*-*-*" device t)
  539.       (make-font-instance "-*-*-*-r-*-*-*-120-*-*-m-*-*-*" device t)
  540.       (make-font-instance "-*-*-*-r-*-*-*-120-*-*-c-*-*-*" device t)
  541.       (make-font-instance "-*-*-*-r-*-*-*-120-*-*-*-*-*-*" device t)
  542.       ;; Hello?  Please?
  543.       (make-font-instance "-*-*-*-*-*-*-*-120-*-*-*-*-*-*" device t)
  544.       (make-font-instance "*" device t)
  545.       ;; if we get to here we're screwed, and faces.c will fatal()...
  546.       ))
  547.      (if (not (face-font 'default 'global))
  548.      (set-face-font 'default new-x-font)
  549.        (set-face-font 'default new-x-font device))))
  550.   ;;
  551.   ;; If the "default" face didn't have both colors specified, then pick
  552.   ;; some, taking into account whether one of the colors was specified.  
  553.   ;;
  554.   (let ((fg (face-foreground-instance 'default device))
  555.     (bg (face-background-instance 'default device)))
  556.     (if (not (and fg bg))
  557.     (if (or (and fg (equal (downcase (color-instance-name fg)) "white"))
  558.         (and bg (equal (downcase (color-instance-name bg)) "black")))
  559.         (progn
  560.           (or fg (set-face-foreground 'default "white" device))
  561.           (or bg (set-face-background 'default "black" device)))
  562.       (or fg (set-face-foreground 'default "black" device))
  563.       (or bg (set-face-background 'default "white" device)))))
  564.  
  565.   ;; Don't look at reverseVideo now or initialize the modeline.  This
  566.   ;; is done on a per-frame basis at the appropriate time.
  567.  
  568.   ;;
  569.   ;; Now let's try to pick some reasonable defaults for a few other faces.
  570.   ;; This kind of stuff should normally go on the create-frame-hook, but
  571.   ;; this way we won't be in danger of the user screwing things up by not
  572.   ;; adding hooks in a safe way.
  573.   ;;
  574.   (x-init-other-random-faces device)
  575.   (x-init-pointer-shape device)  ; from x-mouse.el
  576.     )
  577.  
  578. ;;; This is called from `init-frame-faces', which is called from 
  579. ;;; init_frame_faces() which is called from Fmake_frame(), to perform
  580. ;;; any device-specific initialization.
  581. ;;;
  582. (defun x-init-frame-faces (frame)
  583.   ;;
  584.   ;; The faces already got initialized (by init-frame-faces) from
  585.   ;; the resource database or global, non-frame faces.  The default,
  586.   ;; bold, bold-italic, and italic faces (plus various other random faces)
  587.   ;; got set up then.  But modeline didn't so that reverseVideo can be
  588.   ;; frame-specific.
  589.   ;;
  590.  
  591.   ;;
  592.   ;; If reverseVideo was specified, swap the foreground and background
  593.   ;; of the default and modeline faces.
  594.   ;;
  595.   (cond ((car (x-get-resource "reverseVideo" "ReverseVideo" 'boolean frame))
  596.      ;; First make sure the modeline has fg and bg, inherited from the
  597.      ;; current default face - for the case where only one is specified,
  598.      ;; so that invert-face doesn't do something weird.
  599.      (or (face-foreground 'modeline frame)
  600.          (set-face-foreground 'modeline
  601.                   (face-foreground-instance 'default frame)
  602.                   frame))
  603.      (or (face-background 'modeline frame)
  604.          (set-face-background 'modeline
  605.                   (face-background-instance 'default frame)
  606.                   frame))
  607.      ;; Now invert both of them.  If they end up looking the same,
  608.      ;; make-frame-initial-faces will invert the modeline again later.
  609.      (invert-face 'default frame)
  610.      (invert-face 'modeline frame)
  611.      )))
  612.  
  613. ;; These warnings are there for a reason.
  614. ;; Just specify your fonts correctly.  Deal with it.
  615. ;(defvar x-inhibit-font-complaints nil
  616. ;  "Whether to suppress complaints about incomplete sets of fonts.")
  617.  
  618. (defun x-complain-about-font (face device)
  619.   (if (symbolp face) (setq face (symbol-name face)))
  620. ;;  (if (not x-inhibit-font-complaints)
  621.       (display-warning
  622.        'font
  623.        (format "%s: couldn't deduce %s %s version of %S\n"
  624.         invocation-name
  625.         (if (string-match "\\`[aeiouAEIOU]" face) "an" "a")
  626.         face
  627.         (face-font-name 'default device)))
  628. ;;    )
  629.   )
  630.  
  631. (defun x-init-other-random-faces (device)
  632.   "Initializes the colors and fonts of the bold, italic, bold-italic,
  633. zmacs-region, highlight, primary-selection, secondary-selection, and
  634. isearch faces when each device is created.  If you want to add code to
  635. do stuff like this, use the create-device-hook."
  636.  
  637.   ;; try to make 'bold look different from the default on this device.
  638.   ;; If that doesn't work at all, then issue a warning.
  639.   (or (face-differs-from-default-p 'bold device)
  640.       (make-face-bold 'bold device))
  641.   (or (face-differs-from-default-p 'bold device)
  642.       (make-face-unbold 'bold device))
  643.   (or (face-differs-from-default-p 'bold device)
  644.       ;; otherwise the luser specified one of the bogus font names
  645.       (x-complain-about-font 'bold device))
  646.  
  647.   ;; similar for italic.
  648.   (or (face-differs-from-default-p 'italic device)
  649.       (make-face-italic 'italic device))
  650.   (or (face-differs-from-default-p 'italic device)
  651.       (progn
  652.     (make-face-bold 'bold device) ; bold if possible, then complain
  653.     (x-complain-about-font 'italic device)))
  654.  
  655.   ;; similar for bold-italic.
  656.   (or (face-differs-from-default-p 'bold-italic device)
  657.       (make-face-bold-italic 'bold-italic device))
  658.   ;; if we couldn't get a bold-italic version, try just bold.
  659.   (or (face-differs-from-default-p 'bold-italic device)
  660.       (make-face-bold-italic 'bold-italic device))
  661.   ;; if we couldn't get bold or bold-italic, then that's probably because
  662.   ;; the default font is bold, so make the `bold-italic' face be unbold.
  663.   (or (face-differs-from-default-p 'bold-italic device)
  664.       (progn
  665.     (make-face-unbold 'bold-italic device)
  666.     (make-face-italic 'bold-italic device)))
  667.   (or (face-differs-from-default-p 'bold-italic device)
  668.       (progn
  669.       ;; if that didn't work, try italic (can this ever happen? what the hell.)
  670.     (make-face-italic 'bold-italic device)
  671.     ;; then bitch and moan.
  672.     (x-complain-about-font 'bold-italic device)))
  673.  
  674.   ;; note that making an existing face has no effect.
  675.   ;; note also that x-resource-faces will be called from the
  676.   ;; C code when a new face is made.
  677.   (make-face 'primary-selection)
  678.   (make-face 'secondary-selection)
  679.   (make-face 'isearch)
  680.  
  681.   ;; first time through, set the secondary-selection color if it's not already
  682.   ;; specified.
  683.   (if (and (not (face-differs-from-default-p 'highlight device))
  684.        (not (face-background 'highlight 'global)))
  685.       (progn
  686.     ;; some older servers don't recognize "darkseagreen2"
  687.         (set-face-background 'highlight
  688.                  '((color . "darkseagreen2")
  689.                    (color . "green"))
  690.                  'global nil 'append)
  691.     (set-face-background 'highlight "gray1" 'global 'grayscale 'append)))
  692.   (if (not (face-background-pixmap 'highlight 'global))
  693.       (progn
  694.     (set-face-background-pixmap 'highlight [nothing] 'global 'color
  695.                     'append)
  696.     (set-face-background-pixmap 'highlight [nothing] 'global 'grayscale
  697.                     'append)
  698.     (set-face-background-pixmap 'highlight "gray1" 'global 'mono 'append)))
  699.   ;; if the highlight face isn't distinguished on this device,
  700.   ;; at least try inverting it.
  701.   (or (face-differs-from-default-p 'highlight device)
  702.       (invert-face 'highlight device))
  703.  
  704.   ;; first time through, set the zmacs-region color if it's not already
  705.   ;; specified.
  706.   (if (and (not (face-differs-from-default-p 'zmacs-region device))
  707.        (not (face-background 'zmacs-region 'global)))
  708.       (progn
  709.     (set-face-background 'zmacs-region "gray" 'global 'color)
  710.     (set-face-background 'zmacs-region "gray3" 'global 'grayscale)))
  711.   (if (not (face-background-pixmap 'zmacs-region 'global))
  712.       (progn
  713.     (set-face-background-pixmap 'zmacs-region [nothing] 'global 'color)
  714.     (set-face-background-pixmap 'zmacs-region [nothing] 'global 'grayscale)
  715.     (set-face-background-pixmap 'zmacs-region "gray3" 'global 'mono)))
  716.   ;; if the zmacs-region face isn't distinguished on this device,
  717.   ;; at least try inverting it.
  718.   (or (face-differs-from-default-p 'zmacs-region device)
  719.       (invert-face 'zmacs-region device))
  720.  
  721.   ;; first time through, set the primary-selection color if it's not already
  722.   ;; specified.
  723.   (if (and (not (face-differs-from-default-p 'primary-selection device))
  724.        (not (face-background 'primary-selection 'global)))
  725.       (progn
  726.     (set-face-background 'primary-selection "gray" 'global 'color)
  727.     (set-face-background 'primary-selection "gray3" 'global 'grayscale)))
  728.   (if (not (face-background-pixmap 'primary-selection 'global))
  729.       (set-face-background-pixmap 'primary-selection "gray3" 'global 'mono))
  730.   ;; if the primary-selection face isn't distinguished on this device,
  731.   ;; at least try inverting it.
  732.   (or (face-differs-from-default-p 'primary-selection device)
  733.       (invert-face 'primary-selection device))
  734.  
  735.   ;; first time through, set the secondary-selection color if it's not already
  736.   ;; specified.
  737.   (if (not (face-background 'secondary-selection 'global))
  738.       (progn
  739.     (if (not (face-differs-from-default-p 'secondary-selection device))
  740.         ;; some older servers don't recognize "paleturquoise"
  741.         (set-face-background 'secondary-selection
  742.                  '((color . "paleturquoise")
  743.                    (color . "green"))
  744.                  'global))
  745.     (set-face-background 'secondary-selection "gray1" 'global 'grayscale)))
  746.   (if (not (face-background-pixmap 'secondary-selection 'global))
  747.       (set-face-background-pixmap 'secondary-selection "gray1" 'global 'mono))
  748.   ;; if the secondary-selection face isn't distinguished on this device,
  749.   ;; at least try inverting it.
  750.   (or (face-differs-from-default-p 'secondary-selection device)
  751.       (invert-face 'secondary-selection device))
  752.  
  753.   ;; first time through, set the isearch color if it's not already
  754.   ;; specified.
  755.   (if (and (not (face-differs-from-default-p 'isearch device))
  756.        (not (face-background 'isearch 'global)))
  757.       ;; some older servers don't recognize "paleturquoise"
  758.       (set-face-background 'isearch
  759.                '((color . "paleturquoise")
  760.                  (color . "green"))
  761.                 'global))
  762.   ;; if the isearch face isn't distinguished (e.g. we're not on a color
  763.   ;; display), at least try making it bold.
  764.   (or (face-differs-from-default-p 'isearch device)
  765.       (make-face-bold 'isearch device))
  766.   ;; if default font is bold, then make the `isearch' face be unbold.
  767.   (or (face-differs-from-default-p 'isearch device)
  768.       (make-face-unbold 'isearch device))
  769.  
  770.   )
  771.