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 / prim / faces.el < prev    next >
Encoding:
Text File  |  1995-08-15  |  41.4 KB  |  974 lines
  1. ;;; faces.el --- Lisp interface to the C "face" structure
  2. ;; Keywords: faces internal
  3.  
  4. ;; Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc.
  5. ;; Copyright (C) 1995 Board of Trustees, University of Illinois
  6. ;; Copyright (C) 1995 Ben Wing
  7.  
  8. ;; Author: Chuck Thompson <cthomp@cs.uiuc.edu>
  9. ;; Modified (heavily): Ben Wing <wing@netcom.com>
  10.  
  11. ;; Original version written by Jamie Zawinski <jwz@netscape.com> and
  12. ;; substantially overhauled by Ben Wing <wing@spg.amdahl.com> and
  13. ;; Chuck Thompson <cthomp@cs.uiuc.edu>
  14.  
  15. ;; This file is part of XEmacs.
  16.  
  17. ;; XEmacs is free software; you can redistribute it and/or modify it
  18. ;; under the terms of the GNU General Public License as published by
  19. ;; the Free Software Foundation; either version 2, or (at your option)
  20. ;; any later version.
  21.  
  22. ;; XEmacs is distributed in the hope that it will be useful, but
  23. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  24. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  25. ;; General Public License for more details.
  26.  
  27. ;; You should have received a copy of the GNU General Public License
  28. ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  29. ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  30.  
  31. (defun read-face-name (prompt)
  32.   (let (face)
  33.     (while (= (length face) 0) ; nil or ""
  34.       (setq face (completing-read prompt
  35.                   (mapcar '(lambda (x) (list (symbol-name x)))
  36.                       (face-list))
  37.                   nil t)))
  38.     (intern face)))
  39.  
  40. (defun face-interactive (what &optional bool)
  41.   (let* ((fn (intern (concat "face-" what "-instance")))
  42.      (face (read-face-name (format "Set %s of face: " what)))
  43.      (default (if (fboundp fn)
  44.               ;; #### we should distinguish here between
  45.               ;; explicitly setting the value to be the
  46.               ;; same as the default face's value, and
  47.               ;; not setting a value at all.
  48.               (funcall fn face)))
  49.      (value (if bool
  50.             (y-or-n-p (format "Should face %s be %s? "
  51.                       (symbol-name face) bool))
  52.           (read-string (format "Set %s of face %s to: "
  53.                        what (symbol-name face))
  54.            (cond ((font-instance-p default)
  55.               (font-instance-name default))
  56.              ((color-instance-p default)
  57.               (color-instance-name default))
  58.              ((image-instance-p default)
  59.               (image-instance-file-name default))
  60.              (t default))))))
  61.     (list face (if (equal value "") nil value))))
  62.  
  63. (defconst built-in-face-specifiers
  64.   '(foreground background font display-table background-pixmap
  65.            underline highlight dim blinking reverse)
  66.   "A list of the built-in face properties that are specifiers.")
  67.  
  68. (defun face-property (face property &optional locale tag-set exact-p)
  69.   "Return FACE's value of the given PROPERTY.
  70.  
  71. If LOCALE is omitted, the FACE's actual value for PROPERTY will be
  72.   returned.  For built-in properties, this will be a specifier object
  73.   of a type appropriate to the property (e.g. a font or color
  74.   specifier).  For other properties, this could be anything.
  75.  
  76. If LOCALE is supplied, then instead of returning the actual value,
  77.   the specification(s) for the given locale or locale type will
  78.   be returned.  This will only work if the actual value of
  79.   PROPERTY is a specifier (this will always be the case for built-in
  80.   properties, but not or not may apply to user-defined properties).
  81.   If the actual value of PROPERTY is not a specifier, this value
  82.   will simply be returned regardless of LOCALE.
  83.  
  84. The return value will be a list of instantiators (e.g. strings
  85.   specifying a font or color name), or a list of specifications, each
  86.   of which is a cons of a locale and a list of instantiators.
  87.   Specifically, if LOCALE is a particular locale (a buffer, window,
  88.   frame, device, or 'global), a list of instantiators for that locale
  89.   will be returned.  Otherwise, if LOCALE is a locale type (one of
  90.   the symbols 'buffer, 'window, 'frame, or 'device), the specifications
  91.   for all locales of that type will be returned.  Finally, if LOCALE is
  92.   'all, the specifications for all locales of all types will be returned.
  93.  
  94. The specifications in a specifier determine what the value of
  95.   PROPERTY will be in a particular \"domain\" or set of circumstances,
  96.   which is typically a particular Emacs window along with the buffer
  97.   it contains and the frame and device it lies within.  The value
  98.   is derived from the instantiator associated with the most specific
  99.   locale (in the order buffer, window, frame, device, and 'global)
  100.   that matches the domain in question.  In other words, given a domain
  101.   (i.e. an Emacs window, usually), the specifier for PROPERTY will first
  102.   be searched for a specification whose locale is the buffer contained
  103.   within that window; then for a specification whose locale is the window
  104.   itself; then for a specification whose locale is the frame that the
  105.   window is contained within; etc.  The first instantiator that is
  106.   valid for the domain (usually this means that the instantiator is
  107.   recognized by the device [i.e. the X server or TTY device] that the
  108.   domain is on.  The function `face-property-instance' actually does
  109.   all this, and is used to determine how to display the face.
  110.  
  111. See `set-face-property' for the built-in property-names."
  112.  
  113.   (or (facep face) (setq face (get-face face)))
  114.   (let ((value (get face property)))
  115.     (if (and locale
  116.          (or (memq property built-in-face-specifiers)
  117.          (specifierp value)))
  118.     (setq value (specifier-specs value locale tag-set exact-p)))
  119.     value))
  120.  
  121. (defun convert-face-property-into-specifier (face property)
  122.   "Convert PROPERTY on FACE into a specifier, if it's not already."
  123.   (setq face (get-face face))
  124.   (let ((specifier (get face property)))
  125.     ;; if a user-property does not have a specifier but a
  126.     ;; locale was specified, put a specifier there.  
  127.     ;; If there was already a value there, convert it to a
  128.     ;; specifier with the value as its 'global instantiator.
  129.     (if (not (specifierp specifier))
  130.     (let ((new-specifier (make-specifier 'generic)))
  131.       (if (or (not (null specifier))
  132.           ;; make sure the nil returned from `get' wasn't
  133.           ;; actually the value of the property
  134.           (null (get face property t)))
  135.           (add-spec-to-specifier new-specifier specifier))
  136.       (setq specifier new-specifier)
  137.       (put face property specifier)))))
  138.  
  139. (defun face-property-instance (face property
  140.                     &optional domain default no-fallback)
  141.   "Return the instance of FACE's PROPERTY in the specified DOMAIN.
  142.  
  143. Under most circumstances, DOMAIN will be a particular window,
  144.   and the returned instance describes how the specified property
  145.   actually is displayed for that window and the particular buffer
  146.   in it.  Note that this may not be the same as how the property
  147.   appears when the buffer is displayed in a different window or
  148.   frame, or how the property appears in the same window if you
  149.   switch to another buffer in that window; and in those cases,
  150.   the returned instance would be different.
  151.  
  152. The returned instance will typically be a color-instance,
  153.   font-instance, or pixmap-instance object, and you can query
  154.   it using the appropriate object-specific functions.  For example,
  155.   you could use `color-instance-rgb-components' to find out the
  156.   RGB (red, green, and blue) components of how the 'background
  157.   property of the 'highlight face is displayed in a particular
  158.   window.  The results might be different from the results
  159.   you would get for another window (perhaps the user
  160.   specified a different color for the frame that window is on;
  161.   or perhaps the same color was specified but the window is
  162.   on a different X server, and that X server has different RGB
  163.   values for the color from this one).
  164.  
  165. DOMAIN defaults to the selected window if omitted.
  166.  
  167. DOMAIN can be a frame or device, instead of a window.  The value
  168.   returned for a such a domain is used in special circumstances
  169.   when a more specific domain does not apply; for example, a frame
  170.   value might be used for coloring a toolbar, which is conceptually
  171.   attached to a frame rather than a particular window.  The value
  172.   is also useful in determining what the value would be for a
  173.   particular window within the frame or device, if it is not
  174.   overridden by a more specific specification.
  175.  
  176. If PROPERTY does not name a built-in property, its value will
  177.   simply be returned unless it is a specifier object, in which case
  178.   it will be instanced using `specifier-instance'.
  179.  
  180. Optional arguments DEFAULT and NO-FALLBACK are the same as in
  181.   `specifier-instance'."
  182.  
  183.   (or (facep face) (setq face (get-face face)))
  184.   (let ((value (get face property)))
  185.     (if (specifierp value)
  186.     (setq value (specifier-instance value domain default no-fallback)))
  187.     value))
  188.  
  189. (defun set-face-property (face property value &optional locale tag-set
  190.                    how-to-add)
  191.   "Change a property of a FACE.
  192.  
  193. NOTE: If you want to remove a property from a face, use `remove-face-property'
  194.   rather than attempting to set a value of nil for the property.
  195.  
  196. For built-in properties, the actual value of the property is a
  197.   specifier and you cannot change this; but you can change the
  198.   specifications within the specifier, and that is what this function
  199.   will do.  For user-defined properties, you can use this function
  200.   to either change the actual value of the property or, if this value
  201.   is a specifier, change the specifications within it.
  202.  
  203. If PROPERTY is a built-in property, the specifications to be added to
  204.   this property can be supplied in many different ways:
  205.  
  206.   -- If VALUE is a simple instantiator (e.g. a string naming a font or
  207.      color) or a list of instantiators, then the instantiator(s) will
  208.      be added as a specification of the property for the given LOCALE
  209.      (which defaults to 'global if omitted).
  210.   -- If VALUE is a list of specifications (each of which is a cons of
  211.      a locale and a list of instantiators), then LOCALE must be nil
  212.      (it does not make sense to explicitly specify a locale in this
  213.      case), and specifications will be added as given.
  214.   -- If VALUE is a specifier (as would be returned by `face-property'
  215.      if no LOCALE argument is given), then some or all of the
  216.      specifications in the specifier will be added to the property.
  217.      In this case, the function is really equivalent to
  218.      `copy-specifier' and LOCALE has the same semantics (if it is
  219.      a particular locale, the specification for the locale will be
  220.      copied; if a locale type, specifications for all locales of
  221.      that type will be copied; if nil or 'all, then all
  222.      specifications will be copied).
  223.  
  224. HOW-TO-ADD should be either nil or one of the symbols 'prepend,
  225.   'append, 'remove-tag-set-prepend, 'remove-tag-set-append, 'remove-locale,
  226.   'remove-locale-type, or 'remove-all.  See `copy-specifier' and
  227.   `add-spec-to-specifier' for a description of what each of
  228.   these means.  Most of the time, you do not need to worry about
  229.   this argument; the default behavior usually is fine.
  230.  
  231. In general, it is OK to pass an instance object (e.g. as returned
  232.   by `face-property-instance') as an instantiator in place of
  233.   an actual instantiator.  In such a case, the instantiator used
  234.   to create that instance object will be used (for example, if
  235.   you set a font-instance object as the value of the 'font
  236.   property, then the font name used to create that object will
  237.   be used instead).  If some cases, however, doing this
  238.   conversion does not make sense, and this will be noted in
  239.   the documentation for particular types of instance objects.
  240.  
  241. If PROPERTY is not a built-in property, then this function will
  242.   simply set its value if LOCALE is nil.  However, if LOCALE is
  243.   given, then this function will attempt to add VALUE as the
  244.   instantiator for the given LOCALE, using `add-spec-to-specifier'.
  245.   If the value of the property is not a specifier, it will
  246.   automatically be converted into a 'generic specifier.
  247.  
  248.  
  249. The following symbols have predefined meanings:
  250.  
  251.  foreground        The foreground color of the face.
  252.  
  253.  background        The background color of the face.
  254.  
  255.  font            The font used to display text covered by this face.
  256.  
  257.  display-table        The display table of the face.
  258.  
  259.  background-pixmap    The pixmap displayed in the background of the face.
  260.             Only used by faces on X devices.
  261.  
  262.  underline        Underline all text covered by this face.
  263.  
  264.  highlight        Highlight all text covered by this face.
  265.             Only used by faces on TTY devices.
  266.  
  267.  dim            Dim all text covered by this face.
  268.             Only used by faces on TTY devices.
  269.  
  270.  blinking        Blink all text covered by this face.
  271.             Only used by faces on TTY devices.
  272.  
  273.  reverse        Reverse the foreground and background colors.
  274.             Only used by faces on TTY devices.
  275.  
  276.  doc-string        Description of what the face's normal use is.
  277.             NOTE: This is not a specifier, unlike all
  278.             the other built-in properties, and cannot
  279.             contain locale-specific values."
  280.  
  281.   (or (facep face) (setq face (get-face face)))
  282.   (if (memq property built-in-face-specifiers)
  283.       ;; This section adds built-in properties.
  284.       (let ((specifier (get face property))
  285.         (nval value))
  286.     (cond ((specifierp value)
  287.            (copy-specifier value specifier locale tag-set nil how-to-add))
  288.           (t
  289.            (if tag-set
  290.            (progn
  291.              (or (not (consp nval))
  292.              (error
  293.               "Must specify single instantiator if TAG-SET is given"))
  294.              (setq nval
  295.                (cons tag-set nval))))
  296.            (if locale
  297.            (setq nval (cons locale nval)))
  298.            (set-specifier specifier nval how-to-add))))
  299.  
  300.     ;; This section adds user defined properties.
  301.     (if (not locale)
  302.     (put face property value)
  303.       (convert-face-property-into-specifier face property)
  304.       (add-spec-to-specifier (get face property) value locale tag-set how-to-add)))
  305.   value)
  306.  
  307. (defun remove-face-property (face property &optional locale tag-set exact-p)
  308.   "Remove a property from a face.
  309. For built-in properties, this is analogous to `remove-specifier'.
  310. See `remove-specifier' for the meaning of the LOCALE, TAG-SET, and EXACT-P arguments."
  311.   (or locale (setq locale 'all))
  312.   (if (memq property built-in-face-specifiers)
  313.       (remove-specifier (face-property face property) locale tag-set exact-p)
  314.     (if (eq locale 'all)
  315.     (remprop (get-face face) property)
  316.       (convert-face-property-into-specifier face property)
  317.       (remove-specifier (face-property face property) locale tag-set exact-p))))
  318.  
  319. (defun reset-face (face)
  320.   "Clear all existing built-in specifications from FACE.
  321. This makes FACE inherit all its display properties from 'default.
  322. WARNING: Be absolutely sure you want to do this!!!  It is a dangerous
  323. operation and is not undoable."
  324.   (mapcar #'(lambda (x)
  325.           (remove-specifier (face-property face x)))
  326.       built-in-face-specifiers)
  327.   nil)
  328.  
  329. (defun face-doc-string (face)
  330.   "Return the documentation string for FACE."
  331.   (face-property face 'doc-string))
  332.  
  333. (defun set-face-doc-string (face doc-string)
  334.   "Change the documentation string of FACE to DOC-STRING."
  335.   (interactive (face-interactive "doc-string"))
  336.   (set-face-property face 'doc-string doc-string))
  337.  
  338. (defun face-font-name (face &optional domain)
  339.   "Return the font name of the given face, or nil if it is unspecified.
  340. DOMAIN is as in `face-font-instance'."
  341.   (let ((f (face-font-instance face domain)))
  342.     (and f (font-instance-name f))))
  343.  
  344. (defun face-font (face &optional locale tag-set exact-p)
  345.   "Return the font of the given face, or nil if it is unspecified.
  346.  
  347. FACE may be either a face object or a symbol representing a face.
  348.  
  349. LOCALE may be a locale (the instantiators for that particular locale
  350.   will be returned), a locale type (the specifications for all locales
  351.   of that type will be returned), 'all (all specifications will be
  352.   returned), or nil (the actual specifier object will be returned).
  353.  
  354. See `face-property' for more information."
  355.   (face-property face 'font locale tag-set exact-p))
  356.  
  357. (defun face-font-instance (face &optional domain)
  358.   "Return the instance of the given face's font in the given domain.
  359.  
  360. FACE may be either a face object or a symbol representing a face.
  361.  
  362. Normally DOMAIN will be a window or nil (meaning the selected window),
  363.   and an instance object describing how the font appears in that
  364.   particular window and buffer will be returned.
  365.  
  366. See `face-property-instance' for more information."
  367.   (face-property-instance face 'font domain))
  368.  
  369. (defun set-face-font (face font &optional locale tag-set how-to-add)
  370.   "Change the font of the given face.
  371.  
  372. FACE may be either a face object or a symbol representing a face.
  373.  
  374. FONT should be an instantiator (a string naming a font; e.g. under
  375.   X this might be \"-*-courier-medium-r-*-*-*-140-*-*-*-*-iso8859-*\"
  376.   for a 14-point upright medium-weight Courier font), a list of
  377.   instantiators, an alist of specifications (each mapping a
  378.   locale to an instantiator list), or a font specifier object.
  379.  
  380. If FONT is an alist, LOCALE must be omitted.  If FONT is a
  381.   specifier object, LOCALE can be a locale, a locale type, 'all,
  382.   or nil; see `copy-specifier' for its semantics.  Otherwise LOCALE
  383.   specifies the locale under which the specified instantiator(s)
  384.   will be added, and defaults to 'global.
  385.  
  386. See `set-face-property' for more information."
  387.   (interactive (face-interactive "font"))
  388.   (set-face-property face 'font font locale tag-set how-to-add))
  389.  
  390. (defun face-foreground (face &optional locale tag-set exact-p)
  391.   "Return the foreground of the given face, or nil if it is unspecified.
  392.  
  393. FACE may be either a face object or a symbol representing a face.
  394.  
  395. LOCALE may be a locale (the instantiators for that particular locale
  396.   will be returned), a locale type (the specifications for all locales
  397.   of that type will be returned), 'all (all specifications will be
  398.   returned), or nil (the actual specifier object will be returned).
  399.  
  400. See `face-property' for more information."
  401.   (face-property face 'foreground locale tag-set exact-p))
  402.  
  403. (defun face-foreground-instance (face &optional domain default no-fallback)
  404.   "Return the instance of the given face's foreground in the given domain.
  405.  
  406. FACE may be either a face object or a symbol representing a face.
  407.  
  408. Normally DOMAIN will be a window or nil (meaning the selected window),
  409.   and an instance object describing how the foreground appears in that
  410.   particular window and buffer will be returned.
  411.  
  412. See `face-property-instance' for more information."
  413.   (face-property-instance face 'foreground domain default no-fallback))
  414.  
  415. (defun set-face-foreground (face color &optional locale tag-set how-to-add)
  416.   "Change the foreground of the given face.
  417.  
  418. FACE may be either a face object or a symbol representing a face.
  419.  
  420. COLOR should be an instantiator (a string naming a color; e.g. under X
  421.   this might be \"lightseagreen2\" or \"#F534B2\"), a list of
  422.   instantiators, an alist of specifications (each mapping a locale to
  423.   an instantiator list), or a color specifier object.
  424.  
  425. If COLOR is an alist, LOCALE must be omitted.  If COLOR is a
  426.   specifier object, LOCALE can be a locale, a locale type, 'all,
  427.   or nil; see `copy-specifier' for its semantics.  Otherwise LOCALE
  428.   specifies the locale under which the specified instantiator(s)
  429.   will be added, and defaults to 'global.
  430.  
  431. See `set-face-property' for more information."
  432.   (interactive (face-interactive "foreground"))
  433.   (set-face-property face 'foreground color locale tag-set how-to-add))
  434.  
  435. (defun face-background (face &optional locale tag-set exact-p)
  436.   "Return the background of the given face, or nil if it is unspecified.
  437.  
  438. FACE may be either a face object or a symbol representing a face.
  439.  
  440. LOCALE may be a locale (the instantiators for that particular locale
  441.   will be returned), a locale type (the specifications for all locales
  442.   of that type will be returned), 'all (all specifications will be
  443.   returned), or nil (the actual specifier object will be returned).
  444.  
  445. See `face-property' for more information."
  446.   (face-property face 'background locale tag-set exact-p))
  447.  
  448. (defun face-background-instance (face &optional domain default no-fallback)
  449.   "Return the instance of the given face's background in the given domain.
  450.  
  451. FACE may be either a face object or a symbol representing a face.
  452.  
  453. Normally DOMAIN will be a window or nil (meaning the selected window),
  454.   and an instance object describing how the background appears in that
  455.   particular window and buffer will be returned.
  456.  
  457. See `face-property-instance' for more information."
  458.   (face-property-instance face 'background domain default no-fallback))
  459.  
  460. (defun set-face-background (face color &optional locale tag-set how-to-add)
  461.   "Change the background of the given face.
  462.  
  463. FACE may be either a face object or a symbol representing a face.
  464.  
  465. COLOR should be an instantiator (a string naming a color; e.g. under X
  466.   this might be \"lightseagreen2\" or \"#F534B2\"), a list of
  467.   instantiators, an alist of specifications (each mapping a locale to
  468.   an instantiator list), or a color specifier object.
  469.  
  470. If COLOR is an alist, LOCALE must be omitted.  If COLOR is a
  471.   specifier object, LOCALE can be a locale, a locale type, 'all,
  472.   or nil; see `copy-specifier' for its semantics.  Otherwise LOCALE
  473.   specifies the locale under which the specified instantiator(s)
  474.   will be added, and defaults to 'global.
  475.  
  476. See `set-face-property' for more information."
  477.   (interactive (face-interactive "background"))
  478.   (set-face-property face 'background color locale tag-set how-to-add))
  479.  
  480. (defun face-background-pixmap (face &optional locale tag-set exact-p)
  481.   "Return the background pixmap of the given face, or nil if it is unspecified.
  482. This property is only used on X devices.
  483.  
  484. FACE may be either a face object or a symbol representing a face.
  485.  
  486. LOCALE may be a locale (the instantiators for that particular locale
  487.   will be returned), a locale type (the specifications for all locales
  488.   of that type will be returned), 'all (all specifications will be
  489.   returned), or nil (the actual specifier object will be returned).
  490.  
  491. See `face-property' for more information."
  492.   (face-property face 'background-pixmap locale tag-set exact-p))
  493.  
  494. (defun face-background-pixmap-instance (face &optional domain default no-fallback)
  495.   "Return the instance of the given face's background pixmap in the given domain.
  496.  
  497. FACE may be either a face object or a symbol representing a face.
  498.  
  499. Normally DOMAIN will be a window or nil (meaning the selected window),
  500.   and an instance object describing how the background appears in that
  501.   particular window and buffer will be returned.
  502.  
  503. See `face-property-instance' for more information."
  504.   (face-property-instance face 'background-pixmap domain default no-fallback))
  505.  
  506. (defun set-face-background-pixmap (face pixmap &optional locale tag-set how-to-add)
  507.   "Change the background pixmap of the given face.
  508. This property is only used on X devices.
  509.  
  510. FACE may be either a face object or a symbol representing a face.
  511.  
  512. PIXMAP should be an instantiator (the name of a file of pixmap data, a
  513.   string that is the contents of an XPM file if XPM support was
  514.   compiled in, a vector of the from `[width height data]'
  515.   specifying the pixmap data), a list of instantiators, an alist of
  516.   specifications (each mapping a locale to an instantiator list), or an
  517.   image specifier object.
  518.  
  519. If PIXMAP is an alist, LOCALE must be omitted.  If PIXMAP is a
  520.   specifier object, LOCALE can be a locale, a locale type, 'all,
  521.   or nil; see `copy-specifier' for its semantics.  Otherwise LOCALE
  522.   specifies the locale under which the specified instantiator(s)
  523.   will be added, and defaults to 'global.
  524.  
  525. See `set-face-property' for more information."
  526.   (interactive (face-interactive "background-pixmap"))
  527.   (set-face-property face 'background-pixmap pixmap locale tag-set how-to-add))
  528.  
  529. (defun face-display-table (face &optional locale tag-set exact-p)
  530.   "Return the display table of the given face.
  531.  
  532. A vector (as returned by `make-display-table') will be returned.
  533.  
  534. LOCALE may be a locale (the instantiators for that particular locale
  535.   will be returned), a locale type (the specifications for all locales
  536.   of that type will be returned), 'all (all specifications will be
  537.   returned), or nil (the actual specifier object will be returned).
  538.  
  539. See `face-property' for more information."
  540.   (face-property face 'display-table locale tag-set exact-p))
  541.  
  542. (defun face-display-table-instance (face &optional domain default no-fallback)
  543.   "Return the instance of FACE's display table in DOMAIN.
  544. A vector (as returned by `make-display-table') will be returned.
  545.  
  546. See `face-property-instance' for the semantics of the DOMAIN argument."
  547.   (face-property-instance face 'display-table domain default no-fallback))
  548.  
  549. (defun set-face-display-table (face display-table &optional locale tag-set
  550.                     how-to-add)
  551.   "Change the display table of the given face.
  552. DISPLAY-TABLE should be a vector as returned by `make-display-table'.
  553.  
  554. See `set-face-property' for the semantics of the LOCALE, TAG-SET, and HOW-TO-ADD
  555.   arguments."
  556.   (interactive (face-interactive "display-table"))
  557.   (set-face-property face 'display-table display-table locale tag-set how-to-add))
  558.  
  559. (defun face-underline-p (face &optional domain default no-fallback)
  560.   "Return whether the given face is underlined.
  561. See `face-property-instance' for the semantics of the DOMAIN argument."
  562.   (face-property-instance face 'underline domain default no-fallback))
  563.  
  564. (defun set-face-underline-p (face underline-p &optional locale tag-set how-to-add)
  565.   "Change whether the given face is underlined.
  566. See `set-face-property' for the semantics of the LOCALE, TAG-SET, and HOW-TO-ADD
  567.   arguments."
  568.   (interactive (face-interactive "underline-p" "underlined"))
  569.   (set-face-property face 'underline underline-p locale tag-set how-to-add))
  570.  
  571. (defun face-highlight-p (face &optional domain default no-fallback)
  572.   "Return whether the given face is highlighted (TTY domains only).
  573. See `face-property-instance' for the semantics of the DOMAIN argument."
  574.   (face-property-instance face 'highlight domain default no-fallback))
  575.  
  576. (defun set-face-highlight-p (face highlight-p &optional locale tag-set how-to-add)
  577.   "Change whether the given face is highlighted (TTY locales only).
  578. See `set-face-property' for the semantics of the LOCALE, TAG-SET, and HOW-TO-ADD
  579.   arguments."
  580.   (interactive (face-interactive "highlight-p" "highlighted"))
  581.   (set-face-property face 'highlight highlight-p locale tag-set how-to-add))
  582.  
  583. (defun face-dim-p (face &optional domain default no-fallback)
  584.   "Return whether the given face is dimmed (TTY domains only).
  585. See `face-property-instance' for the semantics of the DOMAIN argument."
  586.   (face-property-instance face 'dim domain default no-fallback))
  587.  
  588. (defun set-face-dim-p (face dim-p &optional locale tag-set how-to-add)
  589.   "Change whether the given face is dimmed (TTY locales only).
  590. See `set-face-property' for the semantics of the LOCALE, TAG-SET, and HOW-TO-ADD
  591.   arguments."
  592.   (interactive (face-interactive "dim-p" "dimmed"))
  593.   (set-face-property face 'dim dim-p locale tag-set how-to-add))
  594.  
  595. (defun face-blinking-p (face &optional domain default no-fallback)
  596.   "Return whether the given face is blinking (TTY domains only).
  597. See `face-property-instance' for the semantics of the DOMAIN argument."
  598.   (face-property-instance face 'blinking domain default no-fallback))
  599.  
  600. (defun set-face-blinking-p (face blinking-p &optional locale tag-set how-to-add)
  601.   "Change whether the given face is blinking (TTY locales only).
  602. See `set-face-property' for the semantics of the LOCALE, TAG-SET, and HOW-TO-ADD
  603.   arguments."
  604.   (interactive (face-interactive "blinking-p" "blinking"))
  605.   (set-face-property face 'blinking blinking-p locale tag-set how-to-add))
  606.  
  607. (defun face-reverse-p (face &optional domain default no-fallback)
  608.   "Return whether the given face is reversed (TTY domains only).
  609. See `face-property-instance' for the semantics of the DOMAIN argument."
  610.   (face-property-instance face 'reverse domain default no-fallback))
  611.  
  612. (defun set-face-reverse-p (face reverse-p &optional locale tag-set how-to-add)
  613.   "Change whether the given face is reversed (TTY locales only).
  614. See `set-face-property' for the semantics of the LOCALE, TAG-SET, and HOW-TO-ADD
  615.   arguments."
  616.   (interactive (face-interactive "reverse-p" "reversed"))
  617.   (set-face-property face 'reverse reverse-p locale tag-set how-to-add))
  618.  
  619.  
  620. (defun face-property-equal (face1 face2 prop domain)
  621.   (equal (face-property-instance face1 prop domain)
  622.      (face-property-instance face2 prop domain)))
  623.  
  624. (defun face-equal-loop (props face1 face2 domain)
  625.   (while (and props
  626.           (face-property-equal face1 face2 (car props) domain))
  627.     (setq props (cdr props)))
  628.   (null props))
  629.  
  630. (defun face-equal (face1 face2 &optional domain)
  631.   "True if the given faces will display in the the same way.
  632. See `face-property-instance' for the semantics of the DOMAIN argument."
  633.   (if (null domain) (setq domain (selected-window)))
  634.   (if (not (valid-specifier-domain-p domain))
  635.       (error "Invalid specifier domain"))
  636.   (let ((device (dfw-device domain))
  637.     (common-props '(foreground background font display-table underline))
  638.     (x-props '(background-pixmap))
  639.     (tty-props '(highlight dim blinking reverse)))
  640.  
  641.     ;; First check the properties which are used in common between the
  642.     ;; x and tty devices.  Then, check those properties specific to
  643.     ;; the particular device type.
  644.     (and (face-equal-loop common-props face1 face2 domain)
  645.      (cond ((eq 'tty (device-type device))
  646.         (face-equal-loop tty-props face1 face2 domain))
  647.            ((eq 'x (device-type device))
  648.         (face-equal-loop x-props face1 face2 domain))
  649.            (t t)))))
  650.  
  651. (defun face-differs-from-default-p (face &optional domain)
  652.   "True if the given face will display differently from the default face.
  653. See `face-property-instance' for the semantics of the DOMAIN argument."
  654.   (not (face-equal face 'default domain)))
  655.  
  656.  
  657. ;; This function is a terrible, disgusting hack!!!!  Need to
  658. ;; separate out the font elements as separate face properties!
  659.  
  660. ;; WE DEMAND LEXICAL SCOPING!!!
  661. ;; WE DEMAND LEXICAL SCOPING!!!
  662. ;; WE DEMAND LEXICAL SCOPING!!!
  663. ;; WE DEMAND LEXICAL SCOPING!!!
  664. ;; WE DEMAND LEXICAL SCOPING!!!
  665. ;; WE DEMAND LEXICAL SCOPING!!!
  666. ;; WE DEMAND LEXICAL SCOPING!!!
  667. ;; WE DEMAND LEXICAL SCOPING!!!
  668. ;; WE DEMAND LEXICAL SCOPING!!!
  669. ;; WE DEMAND LEXICAL SCOPING!!!
  670. ;; WE DEMAND LEXICAL SCOPING!!!
  671. ;; WE DEMAND LEXICAL SCOPING!!!
  672. ;; WE DEMAND LEXICAL SCOPING!!!
  673. ;; WE DEMAND LEXICAL SCOPING!!!
  674. ;; WE DEMAND LEXICAL SCOPING!!!
  675. (defun frob-face-property (face property func &optional locale)
  676.   "Change the specifier for FACE's PROPERTY according to FUNC, in LOCALE.
  677. FUNC should be a function of two arguments (an instance and a device)
  678. that returns a modified name that is valid for the given device.
  679. If LOCALE specifies a valid domain (i.e. a window, frame, or device),
  680. this function instantiates the specifier over that domain, applies FUNC
  681. to the resulting instance, and adds the result back as an instantiator
  682. for that locale.  Otherwise, LOCALE should be a locale, locale type, or
  683. 'all (defaults to 'all if omitted).  For each specification thusly
  684. included: if the locale given is a valid domain, FUNC will be
  685. iterated over all valid instantiators for the device of the domain
  686. until a non-nil result is found (if there is no such result, the
  687. first valid instantiator is used), and that result substituted for
  688. the specification; otherwise, the process just outlined is
  689. iterated over each existing device and the concatenated results
  690. substituted for the specification."
  691.   (let ((sp (face-property face property)))
  692.     (if (valid-specifier-domain-p locale)
  693.     ;; this is easy.
  694.     (let* ((inst (face-property-instance face property locale))
  695.            (name (and inst (funcall func inst (dfw-device locale)))))
  696.       (if name
  697.           (add-spec-to-specifier sp name locale)))
  698.       ;; otherwise, map over all specifications ...
  699.       ;; but first, some further kludging:
  700.       ;; (1) if we're frobbing the global property, make sure
  701.       ;;     that something is there (copy from the default face,
  702.       ;;     if necessary).  Otherwise, something like
  703.       ;;     (make-face-larger 'modeline)
  704.       ;;     won't do anything at all if the modeline simply
  705.       ;;     inherits its font from 'default.
  706.       ;; (2) if we're frobbing a particular locale, nothing would
  707.       ;;     happen if that locale has no instantiators.  So signal
  708.       ;;     an error to indicate this.
  709.       (if (and (or (eq locale 'global) (eq locale 'all) (not locale))
  710.            (not (face-property face property 'global)))
  711.       (copy-specifier (face-property 'default property)
  712.               (face-property face property)
  713.               'global))
  714.       (if (and (valid-specifier-locale-p locale)
  715.            (not (face-property face property locale)))
  716.       (error "Property must have a specification in locale %S" locale))
  717.       (map-specifier
  718.        sp
  719.        #'(lambda (sp locale inst-list func)
  720.        (let* ((device (dfw-device locale))
  721.           ;; if a device can be derived from the locale,
  722.           ;; call frob-face-property-1 for that device.
  723.           ;; Otherwise map frob-face-property-1 over each device.
  724.           (result
  725.            (if device
  726.                (list (frob-face-property-1 sp device inst-list func))
  727.              (mapcar #'(lambda (device)
  728.                  (frob-face-property-1 sp device
  729.                                inst-list func))
  730.                  (device-list))))
  731.           new-result)
  732.          ;; remove duplicates and nils from the obtained list of
  733.          ;; instantiators.
  734.          (mapcar #'(lambda (arg)
  735.              (if (and arg (not (member arg new-result)))
  736.                  (setq new-result (cons arg new-result))))
  737.              result)
  738.          ;; add back in.
  739.          (add-spec-list-to-specifier sp
  740.                      (list (cons locale new-result)))
  741.          ;; tell map-specifier to keep going.
  742.          nil))
  743.        locale
  744.        func))))
  745.  
  746. (defun frob-face-property-1 (sp device inst-list func)
  747.   (let
  748.       (first-valid result)
  749.     (while (and inst-list (not result))
  750.       (let* ((inst-pair (car inst-list))
  751.          (tag-set (car inst-pair))
  752.          (sp-inst (specifier-instance-from-inst-list
  753.                sp device (list inst-pair))))
  754.     (if sp-inst
  755.         (progn
  756.           (if (not first-valid)
  757.           (setq first-valid inst-pair))
  758.           (setq result (funcall func sp-inst device))
  759.               (if result
  760.                   (setq result (cons tag-set result))))))
  761.       (setq inst-list (cdr inst-list)))
  762.     (or result first-valid)))
  763.  
  764. (defun make-face-bold (face &optional locale)
  765.   "Make the face bold, if possible.
  766. This will attempt to make the font bold for X locales and will set the
  767. highlight flag for TTY locales.
  768. See `face-property' for the semantics of the LOCALE argument."
  769.   (interactive (list (read-face-name "Make which face bold: ")))
  770.   ;; handle TTY specific entries
  771.   (set-face-highlight-p face t locale 'tty)
  772.   ;; handle X specific entries
  773.   (frob-face-property face 'font 'x-make-font-bold locale))
  774.  
  775. (defun make-face-italic (face &optional locale)
  776.   "Make the face italic, if possible.
  777. This will attempt to make the font italic for X locales and will set
  778. the underline flag for TTY locales.
  779. See `face-property' for the semantics of the LOCALE argument."
  780.   (interactive (list (read-face-name "Make which face italic: ")))
  781.   ;; handle TTY specific entries
  782.   (set-face-underline-p face t locale 'tty)
  783.   ;; handle X specific entries
  784.   (frob-face-property face 'font 'x-make-font-italic locale))
  785.  
  786. (defun make-face-bold-italic (face &optional locale)
  787.   "Make the face bold and italic, if possible.
  788. This will attempt to make the font bold-italic for X locales and will
  789. set the highlight and underline flags for TTY locales.
  790. See `face-property' for the semantics of the LOCALE argument."
  791.   (interactive (list (read-face-name "Make which face bold-italic: ")))
  792.   ;; handle TTY specific entries
  793.   (set-face-highlight-p face t locale 'tty)
  794.   (set-face-underline-p face t locale 'tty)
  795.   ;; handle X specific entries
  796.   (frob-face-property face 'font 'x-make-font-bold-italic locale))
  797.  
  798. (defun make-face-unbold (face &optional locale)
  799.   "Make the face non-bold, if possible.
  800. This will attempt to make the font non-bold for X locales and will
  801. unset the highlight flag for TTY locales.
  802. See `face-property' for the semantics of the LOCALE argument."
  803.   (interactive (list (read-face-name "Make which face non-bold: ")))
  804.   ;; handle TTY specific entries
  805.   (set-face-highlight-p face nil locale 'tty)
  806.   ;; handle X specific entries
  807.   (frob-face-property face 'font 'x-make-font-unbold locale))
  808.  
  809. (defun make-face-unitalic (face &optional locale)
  810.   "Make the face non-italic, if possible.
  811. This will attempt to make the font non-italic for X locales and will
  812. unset the underline flag for TTY locales.
  813. See `face-property' for the semantics of the LOCALE argument."
  814.   (interactive (list (read-face-name "Make which face non-italic: ")))
  815.   ;; handle TTY specific entries
  816.   (set-face-underline-p face nil locale 'tty)
  817.   ;; handle X specific entries
  818.   (frob-face-property face 'font 'x-make-font-unitalic locale))
  819.  
  820. (defun make-face-smaller (face &optional locale)
  821.   "Make the font of the given face be smaller, if possible.
  822. See `face-property' for the semantics of the LOCALE argument."
  823.   (interactive (list (read-face-name "Shrink which face: ")))
  824.   ;; handle X specific entries
  825.   (frob-face-property face 'font 'x-find-smaller-font locale))
  826.  
  827. (defun make-face-larger (face &optional locale)
  828.   "Make the font of the given face be larger, if possible.
  829. See `face-property' for the semantics of the LOCALE argument."
  830.   (interactive (list (read-face-name "Enlarge which face: ")))
  831.   ;; handle X specific entries
  832.   (frob-face-property face 'font 'x-find-larger-font locale))
  833.  
  834. (defun invert-face (face &optional locale)
  835.   "Swap the foreground and background colors of the face."
  836.   (if (valid-specifier-domain-p locale)
  837.       (let ((foreface (face-foreground-instance face locale)))
  838.     (set-face-foreground face (face-background-instance face locale)
  839.                  locale)
  840.     (set-face-background face foreface locale))
  841.     (let ((forespec (copy-specifier (face-foreground face) nil locale)))
  842.       (copy-specifier (face-background face) (face-foreground face) locale)
  843.       (copy-specifier forespec (face-background face) locale))))
  844.  
  845.  
  846. ;;; Convenience function
  847. (defun face-height (face &optional domain)
  848.   "Return the height of a face.
  849. See `face-property-instance' for the semantics of the DOMAIN argument."
  850.   (+ (face-ascent face domain) (face-descent face domain)))
  851.  
  852.  
  853. (defun init-face-from-resources (face &optional locale)
  854.   "Initialize FACE from the resource database.
  855. If LOCALE is specified, it should be a frame, device, or 'global, and
  856. the face will be resourced over that locale.  Otherwise, the face will
  857. be resourced over all possible locales (i.e. all frames, all devices,
  858. and 'global)."
  859.   (if (not locale)
  860.       (progn
  861.     (init-face-from-resources face 'global)
  862.     (let ((devices (device-list)))
  863.       (while devices
  864.         (init-face-from-resources face (car devices))
  865.         (setq devices (cdr devices))))
  866.     (let ((frames (frame-list)))
  867.       (while frames
  868.         (init-face-from-resources face (car frames))
  869.         (setq frames (cdr frames)))))
  870.     (let ((devtype (cond ((devicep locale) (device-type locale))
  871.              ((framep locale) (frame-type locale))
  872.              (t nil))))
  873.       (cond ((or (and (not devtype) (featurep 'x)) (eq 'x devtype))
  874.          (x-init-face-from-resources face locale))
  875.         ((or (not devtype) (eq 'tty devtype))
  876.          ;; Nothing to do for TTYs?
  877.          )))))
  878.  
  879. (defun init-device-faces (device)
  880.   ;; First, add any device-local face resources.
  881.   (let ((faces (face-list)))
  882.     (while faces
  883.       (init-face-from-resources (car faces) device)
  884.       (setq faces (cdr faces))))
  885.   ;; Then do any device-specific initialization.
  886.   (cond ((eq 'x (device-type device))
  887.      (x-init-device-faces device))
  888.     ;; Nothing to do for TTYs?
  889.     ))
  890.  
  891. (defun init-frame-faces (frame)
  892.   ;; First, add any frame-local face resources.
  893.   (let ((faces (face-list)))
  894.     (while faces
  895.       (init-face-from-resources (car faces) frame)
  896.       (setq faces (cdr faces))))
  897.   ;; Then do any frame-specific initialization.
  898.   (cond ((eq 'x (frame-type frame))
  899.      (x-init-frame-faces frame))
  900.     ;; Is there anything which should be done for TTY's?
  901.     ))
  902.  
  903. ;; #### This is somewhat X-specific, and is called when the first
  904. ;; X device is created (even if there were TTY devices created
  905. ;; beforehand).  The concept of resources has not been generalized
  906. ;; outside of X-specificness, so we have to live with this
  907. ;; breach of device-independence.
  908.  
  909. (defun init-global-faces ()
  910.   ;; Look for global face resources.
  911.   (let ((faces (face-list)))
  912.     (while faces
  913.       (init-face-from-resources (car faces) 'global)
  914.       (setq faces (cdr faces))))
  915.   ;; Further X frobbing.
  916.   (x-init-global-faces)
  917.   ;; for bold and the like, make the global specification be bold etc.
  918.   ;; if the user didn't already specify a value.  The device-specific X
  919.   ;; code may frob it further.
  920.   (or (face-font 'bold 'global)
  921.       (make-face-bold 'bold 'global))
  922.   ;;
  923.   (or (face-font 'italic 'global)
  924.       (make-face-italic 'italic 'global))
  925.   ;;
  926.   (or (face-font 'bold-italic 'global)
  927.       (make-face-bold-italic 'bold-italic 'global))
  928.   ;;
  929.   ;; Nothing more to be done for X or TTY's?
  930. )
  931.  
  932.  
  933. ;;
  934. ;; Make some useful faces.  This is called very early, before creating
  935. ;; the first non-stream device.  We initialize the tty global values here.
  936. ;; We cannot initialize the X global values here because they depend
  937. ;; on having already resourced the global face specs, which happens
  938. ;; when the first X device is created.  Perhaps with a generalization
  939. ;; of resources it might be possible to clean this up.
  940. ;;
  941. (defun init-faces ()
  942.   ;; the default face is created in init_faces(), just before this
  943.   ;; function is called; this is so that the C code knows what the
  944.   ;; default face is when creating the following faces, so it can
  945.   ;; set it as the default specifier.
  946.   (make-face 'modeline "modeline face")
  947.   (set-face-reverse-p 'modeline t 'global 'tty)
  948.   (set-face-background-pixmap 'modeline [nothing])
  949.   ;;
  950.   (make-face 'highlight "highlight face")
  951.   (set-face-highlight-p 'highlight t 'global 'tty)
  952.   ;;
  953.   (make-face 'left-margin "left margin face")
  954.   ;;
  955.   (make-face 'right-margin "right margin face")
  956.   ;;
  957.   (make-face 'bold "bold text")
  958.   (set-face-highlight-p 'bold t 'global 'tty)
  959.   ;;
  960.   (make-face 'italic "italic text")
  961.   (set-face-underline-p 'italic t 'global 'tty)
  962.   ;;
  963.   (make-face 'bold-italic "bold-italic text")
  964.   (set-face-highlight-p 'bold-italic t 'global 'tty)
  965.   (set-face-underline-p 'bold-italic t 'global 'tty)
  966.   ;;
  967.   (make-face 'zmacs-region "used on defined region between point and mark")
  968.   (set-face-reverse-p 'zmacs-region t 'global 'tty)
  969.   ;;
  970.   ;; The following are faces which are used by packages we dump.
  971.   (make-face 'isearch "used on region matched by isearch")
  972.   (set-face-reverse-p 'isearch t 'global 'tty)
  973.   )
  974.