Implement face-remapping-alist feature

Revision: emacs@sv.gnu.org/emacs--devo--0--patch-1195

5 files changed, 268 insertions, 40 deletions

diff --git a/src/ChangeLog b/src/ChangeLog
index c8cbaf174dd..526d0c07bb0 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,3 +1,37 @@
+2008-06-01  Miles Bader  <miles@gnu.org>
+
+        * xfaces.c (Vface_remapping_alist): New variable.
+        (syms_of_xfaces): Initialize it.
+        (enum named_merge_point_kind): New type.
+        (struct named_merge_point): Add `named_merge_point_kind' field.
+        (push_named_merge_point): Make cycle detection respect different
+        named-merge-point kinds.
+        (lface_from_face_name_no_resolve): Renamed from `lface_from_face_name'.
+        Remove face-name alias resolution.
+        (lface_from_face_name): New definition using
+        `lface_from_face_name_no_resolve'.
+        (get_lface_attributes_no_remap): Renamed from `get_lface_attributes'.
+        Call lface_from_face_name_no_resolve instead of lface_from_face_name.
+        (get_lface_attributes): New definition that layers face-remapping on
+        top of get_lface_attributes_no_remap.  New arg `named_merge_points'.
+        (lookup_basic_face): New function.
+        (lookup_derived_face): Pass new last arg to `get_lface_attributes'.
+        (realize_named_face): Call `get_lface_attributes_no_remap' instead of
+        `get_lface_attributes'.
+        (face_at_buffer_position): Use `lookup_basic_face' to lookup
+        DEFAULT_FACE_ID if necessary.  When optimizing the default-face case,
+        return default_face's face-id instead of the constant DEFAULT_FACE_ID.
+
+        * xdisp.c (init_iterator): Pass base_face_id through
+        `lookup_basic_face' when we actually use it as a face-id.
+        (handle_single_display_prop): Use `lookup_basic_face' to lookup
+        DEFAULT_FACE_ID.
+
+        * fontset.c (Finternal_char_font): Use `lookup_basic_face' to
+        lookup the initial face-id.
+
+        * dispextern.h (lookup_basic_face, Vface_remapping_alist): New decls.
+
 2008-06-01  Juanma Barranquero  <lekktu@gmail.com>
 
         * textprop.c (syms_of_textprop) <text-property-default-nonsticky>:
diff --git a/src/dispextern.h b/src/dispextern.h
index 2101d70478f..4a4c731748b 100644
--- a/src/dispextern.h
+++ b/src/dispextern.h
@@ -2852,6 +2852,7 @@ int xstrcasecmp P_ ((const unsigned char *, const unsigned char *));
 int lookup_face P_ ((struct frame *, Lisp_Object *));
 int lookup_non_ascii_face P_ ((struct frame *, int, struct face *));
 int lookup_named_face P_ ((struct frame *, Lisp_Object, int));
+int lookup_basic_face P_ ((struct frame *, int));
 int smaller_face P_ ((struct frame *, int, int));
 int face_with_height P_ ((struct frame *, int, int));
 int lookup_derived_face P_ ((struct frame *, Lisp_Object, int, int));
@@ -2880,6 +2881,8 @@ extern char unspecified_fg[], unspecified_bg[];
 extern Lisp_Object split_font_name_into_vector P_ ((Lisp_Object));
 extern Lisp_Object build_font_name_from_vector P_ ((Lisp_Object));
 
+extern Lisp_Object Vface_remapping_alist;
+
 /* Defined in xfns.c  */
 
 #ifdef HAVE_X_WINDOWS
diff --git a/src/fontset.c b/src/fontset.c
index d384dd41345..fbc6b866f31 100644
--- a/src/fontset.c
+++ b/src/fontset.c
@@ -1677,7 +1677,7 @@ DEFUN ("internal-char-font", Finternal_char_font, Sinternal_char_font, 1, 2, 0,
       CHECK_CHARACTER (ch);
       c = XINT (ch);
       f = XFRAME (selected_frame);
-      face_id = DEFAULT_FACE_ID;
+      face_id = lookup_basic_face (f, DEFAULT_FACE_ID);
       pos = -1;
       cs_id = -1;
     }
diff --git a/src/xdisp.c b/src/xdisp.c
index 9b934c8803d..8d87123934b 100644
--- a/src/xdisp.c
+++ b/src/xdisp.c
@@ -2491,6 +2491,7 @@ init_iterator (it, w, charpos, bytepos, row, base_face_id)
      enum face_id base_face_id;
 {
   int highlight_region_p;
+  enum face_id remapped_base_face_id = base_face_id;
 
   /* Some precondition checks.  */
   xassert (w != NULL && it != NULL);
@@ -2507,6 +2508,10 @@ init_iterator (it, w, charpos, bytepos, row, base_face_id)
       free_all_realized_faces (Qnil);
     }
 
+  /* Perhaps remap BASE_FACE_ID to a user-specified alternative.  */
+  if (! NILP (Vface_remapping_alist))
+    remapped_base_face_id = lookup_basic_face (XFRAME (w->frame), base_face_id);
+
   /* Use one of the mode line rows of W's desired matrix if
      appropriate.  */
   if (row == NULL)
@@ -2522,7 +2527,7 @@ init_iterator (it, w, charpos, bytepos, row, base_face_id)
   bzero (it, sizeof *it);
   it->current.overlay_string_index = -1;
   it->current.dpvec_index = -1;
-  it->base_face_id = base_face_id;
+  it->base_face_id = remapped_base_face_id;
   it->string = Qnil;
   IT_STRING_CHARPOS (*it) = IT_STRING_BYTEPOS (*it) = -1;
 
@@ -2707,11 +2712,11 @@ init_iterator (it, w, charpos, bytepos, row, base_face_id)
     {
       struct face *face;
 
-      it->face_id = base_face_id;
+      it->face_id = remapped_base_face_id;
 
       /* If we have a boxed mode line, make the first character appear
          with a left box line.  */
-      face = FACE_FROM_ID (it->f, base_face_id);
+      face = FACE_FROM_ID (it->f, remapped_base_face_id);
       if (face->box != FACE_NO_BOX)
         it->start_of_box_run_p = 1;
     }
@@ -4077,7 +4082,8 @@ handle_single_display_spec (it, spec, object, overlay, position,
               /* Value is a multiple of the canonical char height.  */
               struct face *face;
 
-              face = FACE_FROM_ID (it->f, DEFAULT_FACE_ID);
+              face = FACE_FROM_ID (it->f,
+                                   lookup_basic_face (it->f, DEFAULT_FACE_ID));
               new_height = (XFLOATINT (it->font_height)
                             * XINT (face->lface[LFACE_HEIGHT_INDEX]));
             }
@@ -4187,7 +4193,7 @@ handle_single_display_spec (it, spec, object, overlay, position,
           || EQ (XCAR (spec), Qright_fringe))
       && CONSP (XCDR (spec)))
     {
-      int face_id = DEFAULT_FACE_ID;
+      int face_id = lookup_basic_face (it->f, DEFAULT_FACE_ID);
       int fringe_bitmap;
 
       if (!FRAME_WINDOW_P (it->f))
diff --git a/src/xfaces.c b/src/xfaces.c
index b5704ab6174..074b71b13c1 100644
--- a/src/xfaces.c
+++ b/src/xfaces.c
@@ -422,6 +422,23 @@ Lisp_Object Qbitmap_spec_p;
 
 Lisp_Object Vface_new_frame_defaults;
 
+/* Alist of face remappings.  Each element is of the form:
+   (FACE REPLACEMENT...) which causes display of the face FACE to use
+   REPLACEMENT... instead.  REPLACEMENT... is interpreted the same way
+   the value of a `face' text property is: it may be (1) A face name,
+   (2) A list of face names, (3) A property-list of face attribute/value
+   pairs, or (4) A list of face names intermixed with lists containing
+   face attribute/value pairs.
+
+   Multiple entries in REPLACEMENT... are merged together to form the final
+   result, with faces or attributes earlier in the list taking precedence
+   over those that are later.
+
+   Face-name remapping cycles are suppressed; recursive references use
+   the underlying face instead of the remapped face.  */
+
+Lisp_Object Vface_remapping_alist;
+
 /* The next ID to assign to Lisp faces.  */
 
 static int next_lface_id;
@@ -493,7 +510,8 @@ static void map_tty_color P_ ((struct frame *, struct face *,
 static Lisp_Object resolve_face_name P_ ((Lisp_Object, int));
 static int may_use_scalable_font_p P_ ((const char *));
 static void set_font_frame_param P_ ((Lisp_Object, Lisp_Object));
-static int get_lface_attributes P_ ((struct frame *, Lisp_Object, Lisp_Object *, int));
+static int get_lface_attributes P_ ((struct frame *, Lisp_Object, Lisp_Object *,
+                                     int, struct named_merge_point *));
 static int load_pixmap P_ ((struct frame *, Lisp_Object, unsigned *, unsigned *));
 static unsigned char *xstrlwr P_ ((unsigned char *));
 static struct frame *frame_or_selected_frame P_ ((Lisp_Object, int));
@@ -2063,6 +2081,12 @@ check_lface (lface)
 
 /* Face-merge cycle checking.  */
 
+enum named_merge_point_kind
+{
+  NAMED_MERGE_POINT_NORMAL,
+  NAMED_MERGE_POINT_REMAP
+};
+
 /* A `named merge point' is simply a point during face-merging where we
    look up a face by name.  We keep a stack of which named lookups we're
    currently processing so that we can easily detect cycles, using a
@@ -2072,27 +2096,40 @@ check_lface (lface)
 struct named_merge_point
 {
   Lisp_Object face_name;
+  enum named_merge_point_kind named_merge_point_kind;
   struct named_merge_point *prev;
 };
 
 
 /* If a face merging cycle is detected for FACE_NAME, return 0,
    otherwise add NEW_NAMED_MERGE_POINT, which is initialized using
-   FACE_NAME, as the head of the linked list pointed to by
-   NAMED_MERGE_POINTS, and return 1.  */
+   FACE_NAME and NAMED_MERGE_POINT_KIND, as the head of the linked list
+   pointed to by NAMED_MERGE_POINTS, and return 1.  */
 
 static INLINE int
 push_named_merge_point (struct named_merge_point *new_named_merge_point,
                         Lisp_Object face_name,
+                        enum named_merge_point_kind named_merge_point_kind,
                         struct named_merge_point **named_merge_points)
 {
   struct named_merge_point *prev;
 
   for (prev = *named_merge_points; prev; prev = prev->prev)
     if (EQ (face_name, prev->face_name))
-      return 0;
+      {
+        if (prev->named_merge_point_kind == named_merge_point_kind)
+          /* A cycle, so fail.  */
+          return 0;
+        else if (prev->named_merge_point_kind == NAMED_MERGE_POINT_REMAP)
+          /* A remap `hides ' any previous normal merge points
+             (because the remap means that it's actually different face),
+             so as we know the current merge point must be normal, we
+             can just assume it's OK.  */
+          break;
+      }
 
   new_named_merge_point->face_name = face_name;
+  new_named_merge_point->named_merge_point_kind = named_merge_point_kind;
   new_named_merge_point->prev = *named_merge_points;
 
   *named_merge_points = new_named_merge_point;
@@ -2170,22 +2207,17 @@ resolve_face_name (face_name, signal_p)
 /* Return the face definition of FACE_NAME on frame F.  F null means
    return the definition for new frames.  FACE_NAME may be a string or
    a symbol (apparently Emacs 20.2 allowed strings as face names in
-   face text properties; Ediff uses that).  If FACE_NAME is an alias
-   for another face, return that face's definition.  If SIGNAL_P is
-   non-zero, signal an error if FACE_NAME is not a valid face name.
-   If SIGNAL_P is zero, value is nil if FACE_NAME is not a valid face
-   name.  */
-
+   face text properties; Ediff uses that).  If SIGNAL_P is non-zero,
+   signal an error if FACE_NAME is not a valid face name.  If SIGNAL_P
+   is zero, value is nil if FACE_NAME is not a valid face name.  */
 static INLINE Lisp_Object
-lface_from_face_name (f, face_name, signal_p)
+lface_from_face_name_no_resolve (f, face_name, signal_p)
      struct frame *f;
      Lisp_Object face_name;
      int signal_p;
 {
   Lisp_Object lface;
 
-  face_name = resolve_face_name (face_name, signal_p);
-
   if (f)
     lface = assq_no_quit (face_name, f->face_alist);
   else
@@ -2197,9 +2229,28 @@ lface_from_face_name (f, face_name, signal_p)
     signal_error ("Invalid face", face_name);
 
   check_lface (lface);
+
   return lface;
 }
 
+/* Return the face definition of FACE_NAME on frame F.  F null means
+   return the definition for new frames.  FACE_NAME may be a string or
+   a symbol (apparently Emacs 20.2 allowed strings as face names in
+   face text properties; Ediff uses that).  If FACE_NAME is an alias
+   for another face, return that face's definition.  If SIGNAL_P is
+   non-zero, signal an error if FACE_NAME is not a valid face name.
+   If SIGNAL_P is zero, value is nil if FACE_NAME is not a valid face
+   name.  */
+static INLINE Lisp_Object
+lface_from_face_name (f, face_name, signal_p)
+     struct frame *f;
+     Lisp_Object face_name;
+     int signal_p;
+{
+  face_name = resolve_face_name (face_name, signal_p);
+  return lface_from_face_name_no_resolve (f, face_name, signal_p);
+}
+
 
 /* Get face attributes of face FACE_NAME from frame-local faces on
    frame F.  Store the resulting attributes in ATTRS which must point
@@ -2208,26 +2259,65 @@ lface_from_face_name (f, face_name, signal_p)
    Otherwise, value is zero if FACE_NAME is not a face.  */
 
 static INLINE int
-get_lface_attributes (f, face_name, attrs, signal_p)
+get_lface_attributes_no_remap (f, face_name, attrs, signal_p)
      struct frame *f;
      Lisp_Object face_name;
      Lisp_Object *attrs;
      int signal_p;
 {
   Lisp_Object lface;
-  int success_p;
 
-  lface = lface_from_face_name (f, face_name, signal_p);
-  if (!NILP (lface))
+  lface = lface_from_face_name_no_resolve (f, face_name, signal_p);
+
+  if (! NILP (lface))
+    bcopy (XVECTOR (lface)->contents, attrs,
+           LFACE_VECTOR_SIZE * sizeof *attrs);
+
+  return !NILP (lface);
+}
+
+/* Get face attributes of face FACE_NAME from frame-local faces on frame
+   F.  Store the resulting attributes in ATTRS which must point to a
+   vector of Lisp_Objects of size LFACE_VECTOR_SIZE.  If FACE_NAME is an
+   alias for another face, use that face's definition.  If SIGNAL_P is
+   non-zero, signal an error if FACE_NAME does not name a face.
+   Otherwise, value is zero if FACE_NAME is not a face.  */
+
+static INLINE int
+get_lface_attributes (f, face_name, attrs, signal_p, named_merge_points)
+     struct frame *f;
+     Lisp_Object face_name;
+     Lisp_Object *attrs;
+     int signal_p;
+     struct named_merge_point *named_merge_points;
+{
+  Lisp_Object face_remapping;
+
+  face_name = resolve_face_name (face_name, signal_p);
+
+  /* See if SYMBOL has been remapped to some other face (usually this
+     is done buffer-locally).  */
+  face_remapping = assq_no_quit (face_name, Vface_remapping_alist);
+  if (CONSP (face_remapping))
     {
-      bcopy (XVECTOR (lface)->contents, attrs,
-             LFACE_VECTOR_SIZE * sizeof *attrs);
-      success_p = 1;
+      struct named_merge_point named_merge_point;
+
+      if (push_named_merge_point (&named_merge_point,
+                                  face_name, NAMED_MERGE_POINT_REMAP,
+                                  &named_merge_points))
+        {
+          int i;
+
+          for (i = 1; i < LFACE_VECTOR_SIZE; ++i)
+            attrs[i] = Qunspecified;
+
+          return merge_face_ref (f, XCDR (face_remapping), attrs,
+                                 signal_p, named_merge_points);
+        }
     }
-  else
-    success_p = 0;
 
-  return success_p;
+  /* Default case, no remapping.  */
+  return get_lface_attributes_no_remap (f, face_name, attrs, signal_p);
 }
 
 
@@ -2383,8 +2473,8 @@ merge_face_heights (from, to, invalid)
    specified attribute of FROM overrides the corresponding attribute of
    TO; relative attributes in FROM are merged with the absolute value in
    TO and replace it.  NAMED_MERGE_POINTS is used internally to detect
-   loops in face inheritance; it should be 0 when called from other
-   places.  */
+   loops in face inheritance/remapping; it should be 0 when called from
+   other places.  */
 
 static INLINE void
 merge_face_vectors (f, from, to, named_merge_points)
@@ -2459,11 +2549,12 @@ merge_named_face (f, face_name, to, named_merge_points)
   struct named_merge_point named_merge_point;
 
   if (push_named_merge_point (&named_merge_point,
-                              face_name, &named_merge_points))
+                              face_name, NAMED_MERGE_POINT_NORMAL,
+                              &named_merge_points))
     {
       struct gcpro gcpro1;
       Lisp_Object from[LFACE_VECTOR_SIZE];
-      int ok = get_lface_attributes (f, face_name, from, 0);
+      int ok = get_lface_attributes (f, face_name, from, 0, named_merge_points);
 
       if (ok)
         {
@@ -3441,7 +3532,7 @@ update_face_from_frame_parameter (f, param, new_value)
 
       /* Changing the background color might change the background
          mode, so that we have to load new defface specs.
-         Call frame-set-background-mode to do that.  */
+         Call frame-update-face-colors to do that.  */
       XSETFRAME (frame, f);
       call1 (Qframe_set_background_mode, frame);
 
@@ -4647,7 +4738,7 @@ lookup_named_face (f, symbol, signal_p)
         abort ();  /* realize_basic_faces must have set it up  */
     }
 
-  if (!get_lface_attributes (f, symbol, symbol_attrs, signal_p))
+  if (! get_lface_attributes (f, symbol, symbol_attrs, signal_p, 0))
     return -1;
 
   bcopy (default_face->lface, attrs, sizeof attrs);
@@ -4657,6 +4748,58 @@ lookup_named_face (f, symbol, signal_p)
 }
 
 
+/* Return the display face-id of the basic face who's canonical face-id
+   is FACE_ID.  The return value will usually simply be FACE_ID, unless that
+   basic face has bee remapped via Vface_remapping_alist.  This function is
+   conservative: if something goes wrong, it will simply return FACE_ID
+   rather than signal an error.   */
+
+int
+lookup_basic_face (f, face_id)
+     struct frame *f;
+     int face_id;
+{
+  Lisp_Object name, mapping;
+  int remapped_face_id;
+
+  if (NILP (Vface_remapping_alist))
+    return face_id;             /* Nothing to do.  */
+
+  switch (face_id)
+    {
+    case DEFAULT_FACE_ID:               name = Qdefault;                break;
+    case MODE_LINE_FACE_ID:             name = Qmode_line;              break;
+    case MODE_LINE_INACTIVE_FACE_ID:    name = Qmode_line_inactive;     break;
+    case HEADER_LINE_FACE_ID:           name = Qheader_line;            break;
+    case TOOL_BAR_FACE_ID:              name = Qtool_bar;               break;
+    case FRINGE_FACE_ID:                name = Qfringe;                 break;
+    case SCROLL_BAR_FACE_ID:            name = Qscroll_bar;             break;
+    case BORDER_FACE_ID:                name = Qborder;                 break;
+    case CURSOR_FACE_ID:                name = Qcursor;                 break;
+    case MOUSE_FACE_ID:                 name = Qmouse;                  break;
+    case MENU_FACE_ID:                  name = Qmenu;                   break;
+
+    default:
+      abort ();     /* the caller is supposed to pass us a basic face id */
+    }
+
+  /* Do a quick scan through Vface_remapping_alist, and return immediately
+     if there is no remapping for face NAME.  This is just an optimization
+     for the very common no-remapping case.  */
+  mapping = assq_no_quit (name, Vface_remapping_alist);
+  if (NILP (mapping))
+    return face_id;             /* Give up.  */
+
+  /* If there is a remapping entry, lookup the face using NAME, which will
+     handle the remapping too.  */
+  remapped_face_id = lookup_named_face (f, name, 0);
+  if (remapped_face_id < 0)
+    return face_id;             /* Give up. */
+
+  return remapped_face_id;
+}
+
+
 /* Return the ID of the realized ASCII face of Lisp face with ID
    LFACE_ID on frame F.  Value is -1 if LFACE_ID isn't valid.  */
 
@@ -4789,7 +4932,7 @@ lookup_derived_face (f, symbol, face_id, signal_p)
   if (!default_face)
     abort ();
 
-  get_lface_attributes (f, symbol, symbol_attrs, signal_p);
+  get_lface_attributes (f, symbol, symbol_attrs, signal_p, 0);
   bcopy (default_face->lface, attrs, sizeof attrs);
   merge_face_vectors (f, symbol_attrs, attrs, 0);
   return lookup_face (f, attrs);
@@ -5498,7 +5641,7 @@ realize_named_face (f, symbol, id)
   struct face *new_face;
 
   /* The default face must exist and be fully specified.  */
-  get_lface_attributes (f, Qdefault, attrs, 1);
+  get_lface_attributes_no_remap (f, Qdefault, attrs, 1);
   check_lface_attrs (attrs);
   xassert (lface_fully_specified_p (attrs));
 
@@ -5511,7 +5654,7 @@ realize_named_face (f, symbol, id)
     }
 
   /* Merge SYMBOL's face with the default face.  */
-  get_lface_attributes (f, symbol, symbol_attrs, 1);
+  get_lface_attributes_no_remap (f, symbol, symbol_attrs, 1);
   merge_face_vectors (f, symbol_attrs, attrs, 0);
 
   /* Realize the face.  */
@@ -6068,13 +6211,18 @@ face_at_buffer_position (w, pos, region_beg, region_end,
 
   *endptr = endpos;
 
-  default_face = FACE_FROM_ID (f, DEFAULT_FACE_ID);
+
+  /* Perhaps remap BASE_FACE_ID to a user-specified alternative.  */
+  if (NILP (Vface_remapping_alist))
+    default_face = FACE_FROM_ID (f, DEFAULT_FACE_ID);
+  else
+    default_face = FACE_FROM_ID (f, lookup_basic_face (f, DEFAULT_FACE_ID));
 
   /* Optimize common cases where we can use the default face.  */
   if (noverlays == 0
       && NILP (prop)
       && !(pos >= region_beg && pos < region_end))
-    return DEFAULT_FACE_ID;
+    return default_face->id;
 
   /* Begin with attributes from the default face.  */
   bcopy (default_face->lface, attrs, sizeof attrs);
@@ -6673,6 +6821,43 @@ Each element is a regular expression that matches names of fonts to
 ignore.  */);
   Vface_ignored_fonts = Qnil;
 
+  DEFVAR_LISP ("face-remapping-alist", &Vface_remapping_alist,
+               doc: /* Alist of face remappings.
+Each element is of the form:
+
+   (FACE REPLACEMENT...),
+
+which causes display of the face FACE to use REPLACEMENT... instead.
+REPLACEMENT... is interpreted the same way the value of a `face' text
+property is: it may be (1) A face name, (2) A list of face names, (3) A
+property-list of face attribute/value pairs, or (4) A list of face names
+intermixed with lists containing face attribute/value pairs.
+
+Multiple entries in REPLACEMENT... are merged together to form the final
+result, with faces or attributes earlier in the list taking precedence
+over those that are later.
+
+Face-name remapping cycles are suppressed; recursive references use the
+underlying face instead of the remapped face.  So a remapping of the form:
+
+   (FACE EXTRA-FACE... FACE)
+
+or:
+
+   (FACE (FACE-ATTR VAL ...) FACE)
+
+will cause EXTRA-FACE... or (FACE-ATTR VAL ...) to be _merged_ with the
+existing definition of FACE.  Note that for the default face, this isn't
+necessary, as every face inherits from the default face.
+
+Making this variable buffer-local is a good way to allow buffer-specific
+face definitions.  For instance, the mode my-mode could define a face
+`my-mode-default', and then in the mode setup function, do:
+
+   (set (make-local-variable 'face-remapping-alist)
+        '((default my-mode-default)))).  */);
+  Vface_remapping_alist = Qnil;
+
   DEFVAR_LISP ("face-font-rescale-alist", &Vface_font_rescale_alist,
                doc: /* Alist of fonts vs the rescaling factors.
 Each element is a cons (FONT-NAME-PATTERN . RESCALE-RATIO), where