src/faces.c

   1 /* "Face" primitives
   2    Copyright (C) 1994 Free Software Foundation, Inc.
   3    Copyright (C) 1995 Board of Trustees, University of Illinois.
   4    Copyright (C) 1995, 1996 Ben Wing.
   5    Copyright (C) 1995 Sun Microsystems, Inc.
   6
   7 This file is part of XEmacs.
   8
   9 XEmacs is free software; you can redistribute it and/or modify it
  10 under the terms of the GNU General Public License as published by the
  11 Free Software Foundation; either version 2, or (at your option) any
  12 later version.
  13
  14 XEmacs is distributed in the hope that it will be useful, but WITHOUT
  15 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  16 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  17 for more details.
  18
  19 You should have received a copy of the GNU General Public License
  20 along with XEmacs; see the file COPYING.  If not, write to
  21 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22 Boston, MA 02111-1307, USA.  */
  23
  24 /* Synched up with: Not in FSF. */
  25
  26 /* Written by Chuck Thompson and Ben Wing,
  27    based loosely on old face code by Jamie Zawinski. */
  28
  29 #include <config.h>
  30 #include "lisp.h"
  31
  32 #include "buffer.h"
  33 #include "device.h"
  34 #include "elhash.h"
  35 #include "extents.h"
  36 #include "faces.h"
  37 #include "frame.h"
  38 #include "glyphs.h"
  39 #include "objects.h"
  40 #include "specifier.h"
  41 #include "window.h"
  42
  43 Lisp_Object Qfacep;
  44 Lisp_Object Qforeground, Qbackground, Qdisplay_table;
  45 Lisp_Object Qbackground_pixmap, Qunderline, Qdim;
  46 Lisp_Object Qblinking, Qstrikethru;
  47
  48 Lisp_Object Qinit_face_from_resources;
  49 Lisp_Object Qinit_frame_faces;
  50 Lisp_Object Qinit_device_faces;
  51 Lisp_Object Qinit_global_faces;
  52
  53 /* These faces are used directly internally.  We use these variables
  54    to be able to reference them directly and save the overhead of
  55    calling Ffind_face. */
  56 Lisp_Object Vdefault_face, Vmodeline_face, Vgui_element_face;
  57 Lisp_Object Vleft_margin_face, Vright_margin_face, Vtext_cursor_face;
  58 Lisp_Object Vpointer_face, Vvertical_divider_face, Vtoolbar_face, Vwidget_face;
  59
  60 /* Qdefault, Qhighlight, Qleft_margin, Qright_margin defined in general.c */
  61 Lisp_Object Qmodeline, Qgui_element, Qtext_cursor, Qvertical_divider;
  62
  63 /* In the old implementation Vface_list was a list of the face names,
  64    not the faces themselves.  We now distinguish between permanent and
  65    temporary faces.  Permanent faces are kept in a regular hash table,
  66    temporary faces in a weak hash table. */
  67 Lisp_Object Vpermanent_faces_cache;
  68 Lisp_Object Vtemporary_faces_cache;
  69
  70 Lisp_Object Vbuilt_in_face_specifiers;
  71
  72 \f
  73
  74 static Lisp_Object
  75 mark_face (Lisp_Object obj)
  76 {
  77   Lisp_Face *face =  XFACE (obj);
  78
  79   mark_object (face->name);
  80   mark_object (face->doc_string);
  81
  82   mark_object (face->foreground);
  83   mark_object (face->background);
  84   mark_object (face->font);
  85   mark_object (face->display_table);
  86   mark_object (face->background_pixmap);
  87   mark_object (face->underline);
  88   mark_object (face->strikethru);
  89   mark_object (face->highlight);
  90   mark_object (face->dim);
  91   mark_object (face->blinking);
  92   mark_object (face->reverse);
  93
  94   mark_object (face->charsets_warned_about);
  95
  96   return face->plist;
  97 }
  98
  99 static void
 100 print_face (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
 101 {
 102   Lisp_Face *face = XFACE (obj);
 103
 104   if (print_readably)
 105     {
 106       write_c_string ("#s(face name ", printcharfun);
 107       print_internal (face->name, printcharfun, 1);
 108       write_c_string (")", printcharfun);
 109     }
 110   else
 111     {
 112       write_c_string ("#<face ", printcharfun);
 113       print_internal (face->name, printcharfun, 1);
 114       if (!NILP (face->doc_string))
 115         {
 116           write_c_string (" ", printcharfun);
 117           print_internal (face->doc_string, printcharfun, 1);
 118         }
 119       write_c_string (">", printcharfun);
 120     }
 121 }
 122
 123 /* Faces are equal if all of their display attributes are equal.  We
 124    don't compare names or doc-strings, because that would make equal
 125    be eq.
 126
 127    This isn't concerned with "unspecified" attributes, that's what
 128    #'face-differs-from-default-p is for. */
 129 static int
 130 face_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
 131 {
 132   Lisp_Face *f1 = XFACE (obj1);
 133   Lisp_Face *f2 = XFACE (obj2);
 134
 135   depth++;
 136
 137   return
 138     (internal_equal (f1->foreground,         f2->foreground,        depth) &&
 139      internal_equal (f1->background,         f2->background,        depth) &&
 140      internal_equal (f1->font,               f2->font,              depth) &&
 141      internal_equal (f1->display_table,      f2->display_table,     depth) &&
 142      internal_equal (f1->background_pixmap,  f2->background_pixmap, depth) &&
 143      internal_equal (f1->underline,          f2->underline,         depth) &&
 144      internal_equal (f1->strikethru,         f2->strikethru,        depth) &&
 145      internal_equal (f1->highlight,          f2->highlight,         depth) &&
 146      internal_equal (f1->dim,                f2->dim,               depth) &&
 147      internal_equal (f1->blinking,           f2->blinking,          depth) &&
 148      internal_equal (f1->reverse,            f2->reverse,           depth) &&
 149
 150      ! plists_differ (f1->plist, f2->plist, 0, 0, depth + 1));
 151 }
 152
 153 static unsigned long
 154 face_hash (Lisp_Object obj, int depth)
 155 {
 156   Lisp_Face *f = XFACE (obj);
 157
 158   depth++;
 159
 160   /* No need to hash all of the elements; that would take too long.
 161      Just hash the most common ones. */
 162   return HASH3 (internal_hash (f->foreground, depth),
 163                 internal_hash (f->background, depth),
 164                 internal_hash (f->font,       depth));
 165 }
 166
 167 static Lisp_Object
 168 face_getprop (Lisp_Object obj, Lisp_Object prop)
 169 {
 170   Lisp_Face *f = XFACE (obj);
 171
 172   return
 173     (EQ (prop, Qforeground)        ? f->foreground        :
 174      EQ (prop, Qbackground)        ? f->background        :
 175      EQ (prop, Qfont)              ? f->font              :
 176      EQ (prop, Qdisplay_table)     ? f->display_table     :
 177      EQ (prop, Qbackground_pixmap) ? f->background_pixmap :
 178      EQ (prop, Qunderline)         ? f->underline         :
 179      EQ (prop, Qstrikethru)        ? f->strikethru        :
 180      EQ (prop, Qhighlight)         ? f->highlight         :
 181      EQ (prop, Qdim)               ? f->dim               :
 182      EQ (prop, Qblinking)          ? f->blinking          :
 183      EQ (prop, Qreverse)           ? f->reverse           :
 184      EQ (prop, Qdoc_string)        ? f->doc_string        :
 185      external_plist_get (&f->plist, prop, 0, ERROR_ME));
 186 }
 187
 188 static int
 189 face_putprop (Lisp_Object obj, Lisp_Object prop, Lisp_Object value)
 190 {
 191   Lisp_Face *f = XFACE (obj);
 192
 193   if (EQ (prop, Qforeground)        ||
 194       EQ (prop, Qbackground)        ||
 195       EQ (prop, Qfont)              ||
 196       EQ (prop, Qdisplay_table)     ||
 197       EQ (prop, Qbackground_pixmap) ||
 198       EQ (prop, Qunderline)         ||
 199       EQ (prop, Qstrikethru)        ||
 200       EQ (prop, Qhighlight)         ||
 201       EQ (prop, Qdim)               ||
 202       EQ (prop, Qblinking)          ||
 203       EQ (prop, Qreverse))
 204     return 0;
 205
 206   if (EQ (prop, Qdoc_string))
 207     {
 208       if (!NILP (value))
 209         CHECK_STRING (value);
 210       f->doc_string = value;
 211       return 1;
 212     }
 213
 214   external_plist_put (&f->plist, prop, value, 0, ERROR_ME);
 215   return 1;
 216 }
 217
 218 static int
 219 face_remprop (Lisp_Object obj, Lisp_Object prop)
 220 {
 221   Lisp_Face *f = XFACE (obj);
 222
 223   if (EQ (prop, Qforeground)        ||
 224       EQ (prop, Qbackground)        ||
 225       EQ (prop, Qfont)              ||
 226       EQ (prop, Qdisplay_table)     ||
 227       EQ (prop, Qbackground_pixmap) ||
 228       EQ (prop, Qunderline)         ||
 229       EQ (prop, Qstrikethru)        ||
 230       EQ (prop, Qhighlight)         ||
 231       EQ (prop, Qdim)               ||
 232       EQ (prop, Qblinking)          ||
 233       EQ (prop, Qreverse))
 234     return -1;
 235
 236   if (EQ (prop, Qdoc_string))
 237     {
 238       f->doc_string = Qnil;
 239       return 1;
 240     }
 241
 242   return external_remprop (&f->plist, prop, 0, ERROR_ME);
 243 }
 244
 245 static Lisp_Object
 246 face_plist (Lisp_Object obj)
 247 {
 248   Lisp_Face *face = XFACE (obj);
 249   Lisp_Object result = face->plist;
 250
 251   result = cons3 (Qreverse,           face->reverse,           result);
 252   result = cons3 (Qblinking,          face->blinking,          result);
 253   result = cons3 (Qdim,               face->dim,               result);
 254   result = cons3 (Qhighlight,         face->highlight,         result);
 255   result = cons3 (Qstrikethru,        face->strikethru,        result);
 256   result = cons3 (Qunderline,         face->underline,         result);
 257   result = cons3 (Qbackground_pixmap, face->background_pixmap, result);
 258   result = cons3 (Qdisplay_table,     face->display_table,     result);
 259   result = cons3 (Qfont,              face->font,              result);
 260   result = cons3 (Qbackground,        face->background,        result);
 261   result = cons3 (Qforeground,        face->foreground,        result);
 262
 263   return result;
 264 }
 265
 266 static const struct lrecord_description face_description[] = {
 267   { XD_LISP_OBJECT, offsetof (Lisp_Face, name) },
 268   { XD_LISP_OBJECT, offsetof (Lisp_Face, doc_string) },
 269   { XD_LISP_OBJECT, offsetof (Lisp_Face, foreground) },
 270   { XD_LISP_OBJECT, offsetof (Lisp_Face, background) },
 271   { XD_LISP_OBJECT, offsetof (Lisp_Face, font) },
 272   { XD_LISP_OBJECT, offsetof (Lisp_Face, display_table) },
 273   { XD_LISP_OBJECT, offsetof (Lisp_Face, background_pixmap) },
 274   { XD_LISP_OBJECT, offsetof (Lisp_Face, underline) },
 275   { XD_LISP_OBJECT, offsetof (Lisp_Face, strikethru) },
 276   { XD_LISP_OBJECT, offsetof (Lisp_Face, highlight) },
 277   { XD_LISP_OBJECT, offsetof (Lisp_Face, dim) },
 278   { XD_LISP_OBJECT, offsetof (Lisp_Face, blinking) },
 279   { XD_LISP_OBJECT, offsetof (Lisp_Face, reverse) },
 280   { XD_LISP_OBJECT, offsetof (Lisp_Face, plist) },
 281   { XD_LISP_OBJECT, offsetof (Lisp_Face, charsets_warned_about) },
 282   { XD_END }
 283 };
 284
 285 DEFINE_LRECORD_IMPLEMENTATION_WITH_PROPS ("face", face,
 286                                           mark_face, print_face, 0, face_equal,
 287                                           face_hash, face_description, face_getprop,
 288                                           face_putprop, face_remprop,
 289                                           face_plist, Lisp_Face);
 290 \f
 291 /************************************************************************/
 292 /*                             face read syntax                         */
 293 /************************************************************************/
 294
 295 static int
 296 face_name_validate (Lisp_Object keyword, Lisp_Object value,
 297                     Error_behavior errb)
 298 {
 299   if (ERRB_EQ (errb, ERROR_ME))
 300     {
 301       CHECK_SYMBOL (value);
 302       return 1;
 303     }
 304
 305   return SYMBOLP (value);
 306 }
 307
 308 static int
 309 face_validate (Lisp_Object data, Error_behavior errb)
 310 {
 311   int name_seen = 0;
 312   Lisp_Object valw = Qnil;
 313
 314   data = Fcdr (data); /* skip over Qface */
 315   while (!NILP (data))
 316     {
 317       Lisp_Object keyw = Fcar (data);
 318
 319       data = Fcdr (data);
 320       valw = Fcar (data);
 321       data = Fcdr (data);
 322       if (EQ (keyw, Qname))
 323         name_seen = 1;
 324       else
 325         ABORT ();
 326     }
 327
 328   if (!name_seen)
 329     {
 330       maybe_error (Qface, errb, "No face name given");
 331       return 0;
 332     }
 333
 334   if (NILP (Ffind_face (valw)))
 335     {
 336       maybe_signal_simple_error ("No such face", valw, Qface, errb);
 337       return 0;
 338     }
 339
 340   return 1;
 341 }
 342
 343 static Lisp_Object
 344 face_instantiate (Lisp_Object data)
 345 {
 346   return Fget_face (Fcar (Fcdr (data)));
 347 }
 348
 349 \f
 350 /****************************************************************************
 351  *                             utility functions                            *
 352  ****************************************************************************/
 353
 354 static void
 355 reset_face (Lisp_Face *f)
 356 {
 357   f->name = Qnil;
 358   f->doc_string = Qnil;
 359   f->dirty = 0;
 360   f->foreground = Qnil;
 361   f->background = Qnil;
 362   f->font = Qnil;
 363   f->display_table = Qnil;
 364   f->background_pixmap = Qnil;
 365   f->underline = Qnil;
 366   f->strikethru = Qnil;
 367   f->highlight = Qnil;
 368   f->dim = Qnil;
 369   f->blinking = Qnil;
 370   f->reverse = Qnil;
 371   f->plist = Qnil;
 372   f->charsets_warned_about = Qnil;
 373 }
 374
 375 static Lisp_Face *
 376 allocate_face (void)
 377 {
 378   Lisp_Face *result = alloc_lcrecord_type (Lisp_Face, &lrecord_face);
 379
 380   reset_face (result);
 381   return result;
 382 }
 383
 384 \f
 385 /* We store the faces in hash tables with the names as the key and the
 386    actual face object as the value.  Occasionally we need to use them
 387    in a list format.  These routines provide us with that. */
 388 struct face_list_closure
 389 {
 390   Lisp_Object *face_list;
 391 };
 392
 393 static int
 394 add_face_to_list_mapper (Lisp_Object key, Lisp_Object value,
 395                          void *face_list_closure)
 396 {
 397   /* This function can GC */
 398   struct face_list_closure *fcl =
 399     (struct face_list_closure *) face_list_closure;
 400
 401   *(fcl->face_list) = Fcons (XFACE (value)->name, (*fcl->face_list));
 402   return 0;
 403 }
 404
 405 static Lisp_Object
 406 faces_list_internal (Lisp_Object list)
 407 {
 408   Lisp_Object face_list = Qnil;
 409   struct gcpro gcpro1;
 410   struct face_list_closure face_list_closure;
 411
 412   GCPRO1 (face_list);
 413   face_list_closure.face_list = &face_list;
 414   elisp_maphash (add_face_to_list_mapper, list, &face_list_closure);
 415   UNGCPRO;
 416
 417   return face_list;
 418 }
 419
 420 static Lisp_Object
 421 permanent_faces_list (void)
 422 {
 423   return faces_list_internal (Vpermanent_faces_cache);
 424 }
 425
 426 static Lisp_Object
 427 temporary_faces_list (void)
 428 {
 429   return faces_list_internal (Vtemporary_faces_cache);
 430 }
 431
 432 \f
 433 static int
 434 mark_face_as_clean_mapper (Lisp_Object key, Lisp_Object value,
 435                            void *flag_closure)
 436 {
 437   /* This function can GC */
 438   int *flag = (int *) flag_closure;
 439   XFACE (value)->dirty = *flag;
 440   return 0;
 441 }
 442
 443 static void
 444 mark_all_faces_internal (int flag)
 445 {
 446   elisp_maphash (mark_face_as_clean_mapper, Vpermanent_faces_cache, &flag);
 447   elisp_maphash (mark_face_as_clean_mapper, Vtemporary_faces_cache, &flag);
 448 }
 449
 450 void
 451 mark_all_faces_as_clean (void)
 452 {
 453   mark_all_faces_internal (0);
 454 }
 455
 456 /* Currently unused (see the comment in face_property_was_changed()).  */
 457 #if 0
 458 /* #### OBSOLETE ME, PLEASE.  Maybe.  Maybe this is just as good as
 459    any other solution. */
 460 struct face_inheritance_closure
 461 {
 462   Lisp_Object face;
 463   Lisp_Object property;
 464 };
 465
 466 static void
 467 update_inheritance_mapper_internal (Lisp_Object cur_face,
 468                                     Lisp_Object inh_face,
 469                                     Lisp_Object property)
 470 {
 471   /* #### fix this function */
 472   Lisp_Object elt = Qnil;
 473   struct gcpro gcpro1;
 474
 475   GCPRO1 (elt);
 476
 477   for (elt = FACE_PROPERTY_SPEC_LIST (cur_face, property, Qall);
 478        !NILP (elt);
 479        elt = XCDR (elt))
 480     {
 481       Lisp_Object values = XCDR (XCAR (elt));
 482
 483       for (; !NILP (values); values = XCDR (values))
 484         {
 485           Lisp_Object value = XCDR (XCAR (values));
 486           if (VECTORP (value) && XVECTOR_LENGTH (value))
 487             {
 488               if (EQ (Ffind_face (XVECTOR_DATA (value)[0]), inh_face))
 489                 Fset_specifier_dirty_flag
 490                   (FACE_PROPERTY_SPECIFIER (inh_face, property));
 491             }
 492         }
 493     }
 494
 495   UNGCPRO;
 496 }
 497
 498 static int
 499 update_face_inheritance_mapper (const void *hash_key, void *hash_contents,
 500                                 void *face_inheritance_closure)
 501 {
 502   Lisp_Object key, contents;
 503   struct face_inheritance_closure *fcl =
 504     (struct face_inheritance_closure *) face_inheritance_closure;
 505
 506   CVOID_TO_LISP (key, hash_key);
 507   VOID_TO_LISP (contents, hash_contents);
 508
 509   if (EQ (fcl->property, Qfont))
 510     {
 511       update_inheritance_mapper_internal (contents, fcl->face, Qfont);
 512     }
 513   else if (EQ (fcl->property, Qforeground) ||
 514            EQ (fcl->property, Qbackground))
 515     {
 516       update_inheritance_mapper_internal (contents, fcl->face, Qforeground);
 517       update_inheritance_mapper_internal (contents, fcl->face, Qbackground);
 518     }
 519   else if (EQ (fcl->property, Qunderline)  ||
 520            EQ (fcl->property, Qstrikethru) ||
 521            EQ (fcl->property, Qhighlight)  ||
 522            EQ (fcl->property, Qdim)        ||
 523            EQ (fcl->property, Qblinking)   ||
 524            EQ (fcl->property, Qreverse))
 525     {
 526       update_inheritance_mapper_internal (contents, fcl->face, Qunderline);
 527       update_inheritance_mapper_internal (contents, fcl->face, Qstrikethru);
 528       update_inheritance_mapper_internal (contents, fcl->face, Qhighlight);
 529       update_inheritance_mapper_internal (contents, fcl->face, Qdim);
 530       update_inheritance_mapper_internal (contents, fcl->face, Qblinking);
 531       update_inheritance_mapper_internal (contents, fcl->face, Qreverse);
 532     }
 533   return 0;
 534 }
 535
 536 static void
 537 update_faces_inheritance (Lisp_Object face, Lisp_Object property)
 538 {
 539   struct face_inheritance_closure face_inheritance_closure;
 540   struct gcpro gcpro1, gcpro2;
 541
 542   GCPRO2 (face, property);
 543   face_inheritance_closure.face = face;
 544   face_inheritance_closure.property = property;
 545
 546   elisp_maphash (update_face_inheritance_mapper, Vpermanent_faces_cache,
 547                  &face_inheritance_closure);
 548   elisp_maphash (update_face_inheritance_mapper, Vtemporary_faces_cache,
 549                  &face_inheritance_closure);
 550
 551   UNGCPRO;
 552 }
 553 #endif /* 0 */
 554
 555 Lisp_Object
 556 face_property_matching_instance (Lisp_Object face, Lisp_Object property,
 557                                  Lisp_Object charset, Lisp_Object domain,
 558                                  Error_behavior errb, int no_fallback,
 559                                  Lisp_Object depth)
 560 {
 561   Lisp_Object retval =
 562     specifier_instance_no_quit (Fget (face, property, Qnil), charset,
 563                                 domain, errb, no_fallback, depth);
 564
 565   if (UNBOUNDP (retval) && !no_fallback)
 566     {
 567       if (EQ (property, Qfont))
 568         {
 569           if (NILP (memq_no_quit (charset,
 570                                   XFACE (face)->charsets_warned_about)))
 571             {
 572 #ifdef MULE
 573               if (! UNBOUNDP (charset))
 574                 warn_when_safe
 575                   (Qfont, Qwarning,
 576                    "Unable to instantiate font for face %s, charset %s",
 577                    string_data (symbol_name
 578                                 (XSYMBOL (XFACE (face)->name))),
 579                    string_data (symbol_name
 580                                 (XSYMBOL (XCHARSET_NAME (charset)))));
 581               else
 582 #endif
 583                 warn_when_safe (Qfont, Qwarning,
 584                                 "Unable to instantiate font for face %s",
 585                                 string_data (symbol_name
 586                                              (XSYMBOL (XFACE (face)->name))));
 587               XFACE (face)->charsets_warned_about =
 588                 Fcons (charset, XFACE (face)->charsets_warned_about);
 589             }
 590           retval = Vthe_null_font_instance;
 591         }
 592     }
 593
 594   return retval;
 595 }
 596
 597 \f
 598 DEFUN ("facep", Ffacep, 1, 1, 0, /*
 599 Return t if OBJECT is a face.
 600 */
 601        (object))
 602 {
 603   return FACEP (object) ? Qt : Qnil;
 604 }
 605
 606 DEFUN ("find-face", Ffind_face, 1, 1, 0, /*
 607 Retrieve the face of the given name.
 608 If FACE-OR-NAME is a face object, it is simply returned.
 609 Otherwise, FACE-OR-NAME should be a symbol.  If there is no such face,
 610 nil is returned.  Otherwise the associated face object is returned.
 611 */
 612        (face_or_name))
 613 {
 614   Lisp_Object retval;
 615
 616   if (FACEP (face_or_name))
 617     return face_or_name;
 618   CHECK_SYMBOL (face_or_name);
 619
 620   /* Check if the name represents a permanent face. */
 621   retval = Fgethash (face_or_name, Vpermanent_faces_cache, Qnil);
 622   if (!NILP (retval))
 623     return retval;
 624
 625   /* Check if the name represents a temporary face. */
 626   return Fgethash (face_or_name, Vtemporary_faces_cache, Qnil);
 627 }
 628
 629 DEFUN ("get-face", Fget_face, 1, 1, 0, /*
 630 Retrieve the face of the given name.
 631 Same as `find-face' except an error is signalled if there is no such
 632 face instead of returning nil.
 633 */
 634        (name))
 635 {
 636   Lisp_Object face = Ffind_face (name);
 637
 638   if (NILP (face))
 639     signal_simple_error ("No such face", name);
 640   return face;
 641 }
 642
 643 DEFUN ("face-name", Fface_name, 1, 1, 0, /*
 644 Return the name of the given face.
 645 */
 646        (face))
 647 {
 648   return XFACE (Fget_face (face))->name;
 649 }
 650
 651 DEFUN ("built-in-face-specifiers", Fbuilt_in_face_specifiers, 0, 0, 0, /*
 652 Return a list of all built-in face specifier properties.
 653 Don't modify this list!
 654 */
 655        ())
 656 {
 657   return Vbuilt_in_face_specifiers;
 658 }
 659
 660 /* These values are retrieved so often that we make a special
 661    function.
 662 */
 663
 664 void
 665 default_face_font_info (Lisp_Object domain, int *ascent, int *descent,
 666                         int *height, int *width, int *proportional_p)
 667 {
 668   Lisp_Object font_instance;
 669
 670   if (noninteractive)
 671     {
 672       if (ascent)
 673         *ascent = 1;
 674       if (descent)
 675         *descent = 0;
 676       if (height)
 677         *height = 1;
 678       if (width)
 679         *width = 1;
 680       if (proportional_p)
 681         *proportional_p = 0;
 682       return;
 683     }
 684
 685   /* We use ASCII here.  This is probably reasonable because the
 686      people calling this function are using the resulting values to
 687      come up with overall sizes for windows and frames. */
 688   if (WINDOWP (domain))
 689     {
 690       struct face_cachel *cachel;
 691       struct window *w = XWINDOW (domain);
 692
 693       /* #### It's possible for this function to get called when the
 694          face cachels have not been initialized.  I don't know why. */
 695       if (!Dynarr_length (w->face_cachels))
 696         reset_face_cachels (w);
 697       cachel = WINDOW_FACE_CACHEL (w, DEFAULT_INDEX);
 698       font_instance = FACE_CACHEL_FONT (cachel, Vcharset_ascii);
 699     }
 700   else
 701     {
 702       font_instance = FACE_FONT (Vdefault_face, domain, Vcharset_ascii);
 703     }
 704
 705   if (height)
 706     *height = XFONT_INSTANCE (font_instance)->height;
 707   if (width)
 708     *width = XFONT_INSTANCE (font_instance)->width;
 709   if (ascent)
 710     *ascent = XFONT_INSTANCE (font_instance)->ascent;
 711   if (descent)
 712     *descent = XFONT_INSTANCE (font_instance)->descent;
 713   if (proportional_p)
 714     *proportional_p = XFONT_INSTANCE (font_instance)->proportional_p;
 715 }
 716
 717 void
 718 default_face_height_and_width (Lisp_Object domain,
 719                                int *height, int *width)
 720 {
 721   default_face_font_info (domain, 0, 0, height, width, 0);
 722 }
 723
 724 void
 725 default_face_height_and_width_1 (Lisp_Object domain,
 726                                  int *height, int *width)
 727 {
 728   if (window_system_pixelated_geometry (domain))
 729     {
 730       if (height)
 731         *height = 1;
 732       if (width)
 733         *width = 1;
 734     }
 735   else
 736     default_face_height_and_width (domain, height, width);
 737 }
 738
 739 DEFUN ("face-list", Fface_list, 0, 1, 0, /*
 740 Return a list of the names of all defined faces.
 741 If TEMPORARY is nil, only the permanent faces are included.
 742 If it is t, only the temporary faces are included.  If it is any
 743 other non-nil value both permanent and temporary are included.
 744 */
 745        (temporary))
 746 {
 747   Lisp_Object face_list = Qnil;
 748
 749   /* Added the permanent faces, if requested. */
 750   if (NILP (temporary) || !EQ (Qt, temporary))
 751     face_list = permanent_faces_list ();
 752
 753   if (!NILP (temporary))
 754     {
 755       struct gcpro gcpro1;
 756       GCPRO1 (face_list);
 757       face_list = nconc2 (face_list, temporary_faces_list ());
 758       UNGCPRO;
 759     }
 760
 761   return face_list;
 762 }
 763
 764 DEFUN ("make-face", Fmake_face, 1, 3, 0, /*
 765 Define a new face with name NAME (a symbol), described by DOC-STRING.
 766 You can modify the font, color, etc. of a face with the set-face-* functions.
 767 If the face already exists, it is unmodified.
 768 If TEMPORARY is non-nil, this face will cease to exist if not in use.
 769 */
 770        (name, doc_string, temporary))
 771 {
 772   /* This function can GC if initialized is non-zero */
 773   Lisp_Face *f;
 774   Lisp_Object face;
 775
 776   CHECK_SYMBOL (name);
 777   if (!NILP (doc_string))
 778     CHECK_STRING (doc_string);
 779
 780   face = Ffind_face (name);
 781   if (!NILP (face))
 782     return face;
 783
 784   f = allocate_face ();
 785   XSETFACE (face, f);
 786
 787   f->name = name;
 788   f->doc_string = doc_string;
 789   f->foreground = Fmake_specifier (Qcolor);
 790   set_color_attached_to (f->foreground, face, Qforeground);
 791   f->background = Fmake_specifier (Qcolor);
 792   set_color_attached_to (f->background, face, Qbackground);
 793   f->font = Fmake_specifier (Qfont);
 794   set_font_attached_to (f->font, face, Qfont);
 795   f->background_pixmap = Fmake_specifier (Qimage);
 796   set_image_attached_to (f->background_pixmap, face, Qbackground_pixmap);
 797   f->display_table = Fmake_specifier (Qdisplay_table);
 798   f->underline = Fmake_specifier (Qface_boolean);
 799   set_face_boolean_attached_to (f->underline, face, Qunderline);
 800   f->strikethru = Fmake_specifier (Qface_boolean);
 801   set_face_boolean_attached_to (f->strikethru, face, Qstrikethru);
 802   f->highlight = Fmake_specifier (Qface_boolean);
 803   set_face_boolean_attached_to (f->highlight, face, Qhighlight);
 804   f->dim = Fmake_specifier (Qface_boolean);
 805   set_face_boolean_attached_to (f->dim, face, Qdim);
 806   f->blinking = Fmake_specifier (Qface_boolean);
 807   set_face_boolean_attached_to (f->blinking, face, Qblinking);
 808   f->reverse = Fmake_specifier (Qface_boolean);
 809   set_face_boolean_attached_to (f->reverse, face, Qreverse);
 810   if (!NILP (Vdefault_face))
 811     {
 812       /* If the default face has already been created, set it as
 813          the default fallback specifier for all the specifiers we
 814          just created.  This implements the standard "all faces
 815          inherit from default" behavior. */
 816       set_specifier_fallback (f->foreground,
 817                              Fget (Vdefault_face, Qforeground, Qunbound));
 818       set_specifier_fallback (f->background,
 819                              Fget (Vdefault_face, Qbackground, Qunbound));
 820       set_specifier_fallback (f->font,
 821                              Fget (Vdefault_face, Qfont, Qunbound));
 822       set_specifier_fallback (f->background_pixmap,
 823                              Fget (Vdefault_face, Qbackground_pixmap,
 824                                    Qunbound));
 825       set_specifier_fallback (f->display_table,
 826                              Fget (Vdefault_face, Qdisplay_table, Qunbound));
 827       set_specifier_fallback (f->underline,
 828                              Fget (Vdefault_face, Qunderline, Qunbound));
 829       set_specifier_fallback (f->strikethru,
 830                              Fget (Vdefault_face, Qstrikethru, Qunbound));
 831       set_specifier_fallback (f->highlight,
 832                              Fget (Vdefault_face, Qhighlight, Qunbound));
 833       set_specifier_fallback (f->dim,
 834                              Fget (Vdefault_face, Qdim, Qunbound));
 835       set_specifier_fallback (f->blinking,
 836                              Fget (Vdefault_face, Qblinking, Qunbound));
 837       set_specifier_fallback (f->reverse,
 838                              Fget (Vdefault_face, Qreverse, Qunbound));
 839     }
 840
 841   /* Add the face to the appropriate list. */
 842   if (NILP (temporary))
 843     Fputhash (name, face, Vpermanent_faces_cache);
 844   else
 845     Fputhash (name, face, Vtemporary_faces_cache);
 846
 847   /* Note that it's OK if we dump faces.
 848      When we start up again when we're not noninteractive,
 849      `init-global-faces' is called and it resources all
 850      existing faces. */
 851   if (initialized && !noninteractive)
 852     {
 853       struct gcpro gcpro1, gcpro2;
 854
 855       GCPRO2 (name, face);
 856       call1 (Qinit_face_from_resources, name);
 857       UNGCPRO;
 858     }
 859
 860   return face;
 861 }
 862
 863 \f
 864 /*****************************************************************************
 865  initialization code
 866  ****************************************************************************/
 867
 868 void
 869 init_global_faces (struct device *d)
 870 {
 871   /* When making the initial terminal device, there is no Lisp code
 872      loaded, so we can't do this. */
 873   if (initialized && !noninteractive)
 874     {
 875       call_critical_lisp_code (d, Qinit_global_faces, Qnil);
 876     }
 877 }
 878
 879 void
 880 init_device_faces (struct device *d)
 881 {
 882   /* This function can call lisp */
 883
 884   /* When making the initial terminal device, there is no Lisp code
 885      loaded, so we can't do this. */
 886   if (initialized)
 887     {
 888       Lisp_Object tdevice;
 889       XSETDEVICE (tdevice, d);
 890       call_critical_lisp_code (d, Qinit_device_faces, tdevice);
 891     }
 892 }
 893
 894 void
 895 init_frame_faces (struct frame *frm)
 896 {
 897   /* When making the initial terminal device, there is no Lisp code
 898      loaded, so we can't do this. */
 899   if (initialized)
 900     {
 901       Lisp_Object tframe;
 902       XSETFRAME (tframe, frm);
 903
 904       /* DO NOT change the selected frame here.  If the debugger goes off
 905          it will try and display on the frame being created, but it is not
 906          ready for that yet and a horrible death will occur.  Any random
 907          code depending on the selected-frame as an implicit arg should be
 908          tracked down and shot.  For the benefit of the one known,
 909          xpm-color-symbols, make-frame sets the variable
 910          Vframe_being_created to the frame it is making and sets it to nil
 911          when done.  Internal functions that this could trigger which are
 912          currently depending on selected-frame should use this instead.  It
 913          is not currently visible at the lisp level. */
 914       call_critical_lisp_code (XDEVICE (FRAME_DEVICE (frm)),
 915                                Qinit_frame_faces, tframe);
 916     }
 917 }
 918
 919 \f
 920 /****************************************************************************
 921  *                        face cache element functions                      *
 922  ****************************************************************************/
 923
 924 /*
 925
 926 #### Here is a description of how the face cache elements ought
 927 to be redone.  It is *NOT* how they work currently:
 928
 929 However, when I started to go about implementing this, I realized
 930 that there are all sorts of subtle problems with cache coherency
 931 that are coming up.  As it turns out, these problems don't
 932 manifest themselves now due to the brute-force "kill 'em all"
 933 approach to cache invalidation when faces change; but if this
 934 is ever made smarter, these problems are going to come up, and
 935 some of them are very non-obvious.
 936
 937 I'm thinking of redoing the cache code a bit to avoid these
 938 coherency problems.  The bulk of the problems will arise because
 939 the current display structures have simple indices into the
 940 face cache, but the cache can be changed at various times,
 941 which could make the current display structures incorrect.
 942 I guess the dirty and updated flags are an attempt to fix
 943 this, but this approach doesn't really work.
 944
 945 Here's an approach that should keep things clean and unconfused:
 946
 947 1) Imagine a "virtual face cache" that can grow arbitrarily
 948    big and for which the only thing allowed is to add new
 949    elements.  Existing elements cannot be removed or changed.
 950    This way, any pointers in the existing redisplay structure
 951    into the cache never get screwed up. (This is important
 952    because even if a cache element is out of date, if there's
 953    a pointer to it then its contents still accurately describe
 954    the way the text currently looks on the screen.)
 955 2) Each element in the virtual cache either describes exactly
 956    one face, or describes the merger of a number of faces
 957    by some process.  In order to simplify things, for mergers
 958    we do not record which faces or ordering was used, but
 959    simply that this cache element is the result of merging.
 960    Unlike the current implementation, it's important that a
 961    single cache element not be used to both describe a
 962    single face and describe a merger, even if all the property
 963    values are the same.
 964 3) Each cache element can be clean or dirty.  "Dirty" means
 965    that the face that the element points to has been changed;
 966    this gets set at the time the face is changed.  This
 967    way, when looking up a value in the cache, you can determine
 968    whether it's out of date or not.  For merged faces it
 969    does not matter -- we don't record the faces or priority
 970    used to create the merger, so it's impossible to look up
 971    one of these faces.  We have to recompute it each time.
 972    Luckily, this is fine -- doing the merge is much
 973    less expensive than recomputing the properties of a
 974    single face.
 975 4) For each cache element, we keep a hash value. (In order
 976    to hash the boolean properties, we convert each of them
 977    into a different large prime number so that the hashing works
 978    well.) This allows us, when comparing runes, to properly
 979    determine whether the face for that rune has changed.
 980    This will be especially important for TTY's, where there
 981    aren't that many faces and minimizing redraw is very
 982    important.
 983 5) We can't actually keep an infinite cache, but that doesn't
 984    really matter that much.  The only elements we care about
 985    are those that are used by either the current or desired
 986    display structs.  Therefore, we keep a per-window
 987    redisplay iteration number, and mark each element with
 988    that number as we use it.  Just after outputting the
 989    window and synching the redisplay structs, we go through
 990    the cache and invalidate all elements that are not clean
 991    elements referring to a particular face and that do not
 992    have an iteration number equal to the current one.  We
 993    keep them in a chain, and use them to allocate new
 994    elements when possible instead of increasing the Dynarr.
 995
 996    */
 997
 998 /* mark for GC a dynarr of face cachels. */
 999
1000 void
1001 mark_face_cachels (face_cachel_dynarr *elements)
1002 {
1003   int elt;
1004
1005   if (!elements)
1006     return;
1007
1008   for (elt = 0; elt < Dynarr_length (elements); elt++)
1009     {
1010       struct face_cachel *cachel = Dynarr_atp (elements, elt);
1011
1012       {
1013         int i;
1014
1015         for (i = 0; i < NUM_LEADING_BYTES; i++)
1016           if (!NILP (cachel->font[i]) && !UNBOUNDP (cachel->font[i]))
1017             mark_object (cachel->font[i]);
1018       }
1019       mark_object (cachel->face);
1020       mark_object (cachel->foreground);
1021       mark_object (cachel->background);
1022       mark_object (cachel->display_table);
1023       mark_object (cachel->background_pixmap);
1024     }
1025 }
1026
1027 /* ensure that the given cachel contains an updated font value for
1028    the given charset.  Return the updated font value. */
1029
1030 Lisp_Object
1031 ensure_face_cachel_contains_charset (struct face_cachel *cachel,
1032                                      Lisp_Object domain, Lisp_Object charset)
1033 {
1034   Lisp_Object new_val;
1035   Lisp_Object face = cachel->face;
1036   int bound = 1;
1037   int offs = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
1038
1039   if (!UNBOUNDP (cachel->font[offs])
1040       && cachel->font_updated[offs])
1041     return cachel->font[offs];
1042
1043   if (UNBOUNDP (face))
1044     {
1045       /* a merged face. */
1046       int i;
1047       struct window *w = XWINDOW (domain);
1048
1049       new_val = Qunbound;
1050       cachel->font_specified[offs] = 0;
1051       for (i = 0; i < cachel->nfaces; i++)
1052         {
1053           struct face_cachel *oth;
1054
1055           oth = Dynarr_atp (w->face_cachels,
1056                             FACE_CACHEL_FINDEX_UNSAFE (cachel, i));
1057           /* Tout le monde aime la recursion */
1058           ensure_face_cachel_contains_charset (oth, domain, charset);
1059
1060           if (oth->font_specified[offs])
1061             {
1062               new_val = oth->font[offs];
1063               cachel->font_specified[offs] = 1;
1064               break;
1065             }
1066         }
1067
1068       if (!cachel->font_specified[offs])
1069         /* need to do the default face. */
1070         {
1071           struct face_cachel *oth =
1072             Dynarr_atp (w->face_cachels, DEFAULT_INDEX);
1073           ensure_face_cachel_contains_charset (oth, domain, charset);
1074
1075           new_val = oth->font[offs];
1076         }
1077
1078       if (!UNBOUNDP (cachel->font[offs]) && !EQ (cachel->font[offs], new_val))
1079         cachel->dirty = 1;
1080       cachel->font_updated[offs] = 1;
1081       cachel->font[offs] = new_val;
1082       return new_val;
1083     }
1084
1085   new_val = face_property_matching_instance (face, Qfont, charset, domain,
1086                                              /* #### look into ERROR_ME_NOT */
1087                                              ERROR_ME_NOT, 1, Qzero);
1088   if (UNBOUNDP (new_val))
1089     {
1090       bound = 0;
1091       new_val = face_property_matching_instance (face, Qfont,
1092                                                  charset, domain,
1093                                                  /* #### look into
1094                                                     ERROR_ME_NOT */
1095                                                  ERROR_ME_NOT, 0, Qzero);
1096     }
1097   if (!UNBOUNDP (cachel->font[offs]) && !EQ (new_val, cachel->font[offs]))
1098     cachel->dirty = 1;
1099   cachel->font_updated[offs] = 1;
1100   cachel->font[offs] = new_val;
1101   cachel->font_specified[offs] = (bound || EQ (face, Vdefault_face));
1102   return new_val;
1103 }
1104
1105 /* Ensure that the given cachel contains updated fonts for all
1106    the charsets specified. */
1107
1108 void
1109 ensure_face_cachel_complete (struct face_cachel *cachel,
1110                              Lisp_Object domain, Charset_ID *charsets)
1111 {
1112   int i;
1113
1114   for (i = 0; i < NUM_LEADING_BYTES; i++)
1115     if (charsets[i])
1116       {
1117         Lisp_Object charset = CHARSET_BY_LEADING_BYTE (i + MIN_LEADING_BYTE);
1118         assert (CHARSETP (charset));
1119         ensure_face_cachel_contains_charset (cachel, domain, charset);
1120       }
1121 }
1122
1123 void
1124 face_cachel_charset_font_metric_info (struct face_cachel *cachel,
1125                                       Charset_ID *charsets,
1126                                       struct font_metric_info *fm)
1127 {
1128   int i;
1129
1130   fm->width = 1;
1131   fm->height = fm->ascent = 1;
1132   fm->descent = 0;
1133   fm->proportional_p = 0;
1134
1135   for (i = 0; i < NUM_LEADING_BYTES; i++)
1136     {
1137       if (charsets[i])
1138         {
1139           Lisp_Object charset = CHARSET_BY_LEADING_BYTE (i + MIN_LEADING_BYTE);
1140           Lisp_Object font_instance = FACE_CACHEL_FONT (cachel, charset);
1141           Lisp_Font_Instance *fi = XFONT_INSTANCE (font_instance);
1142
1143           assert (CHARSETP (charset));
1144           assert (FONT_INSTANCEP (font_instance));
1145
1146           if (fm->ascent  < (int) fi->ascent)  fm->ascent  = (int) fi->ascent;
1147           if (fm->descent < (int) fi->descent) fm->descent = (int) fi->descent;
1148           fm->height = fm->ascent + fm->descent;
1149           if (fi->proportional_p)
1150             fm->proportional_p = 1;
1151           if (EQ (charset, Vcharset_ascii))
1152             fm->width = fi->width;
1153         }
1154     }
1155 }
1156
1157 #define FROB(field)                                                          \
1158   do {                                                                       \
1159     Lisp_Object new_val =                                                    \
1160       FACE_PROPERTY_INSTANCE (face, Q##field, domain, 1, Qzero);             \
1161     int bound = 1;                                                           \
1162     if (UNBOUNDP (new_val))                                                  \
1163       {                                                                      \
1164         bound = 0;                                                           \
1165         new_val = FACE_PROPERTY_INSTANCE (face, Q##field, domain, 0, Qzero); \
1166       }                                                                      \
1167     if (!EQ (new_val, cachel->field))                                        \
1168       {                                                                      \
1169         cachel->field = new_val;                                             \
1170         cachel->dirty = 1;                                                   \
1171       }                                                                      \
1172     cachel->field##_specified = (bound || default_face);                     \
1173   } while (0)
1174
1175 /*
1176  * A face's background pixmap will override the face's
1177  * background color.  But the background pixmap of the
1178  * default face should not override the background color of
1179  * a face if the background color has been specified or
1180  * inherited.
1181  *
1182  * To accomplish this we remove the background pixmap of the
1183  * cachel and mark it as having been specified so that cachel
1184  * merging won't override it later.
1185  */
1186 #define MAYBE_UNFROB_BACKGROUND_PIXMAP          \
1187 do                                              \
1188 {                                               \
1189   if (! default_face                            \
1190       && cachel->background_specified           \
1191       && ! cachel->background_pixmap_specified) \
1192     {                                           \
1193       cachel->background_pixmap = Qunbound;     \
1194       cachel->background_pixmap_specified = 1;  \
1195     }                                           \
1196 } while (0)
1197
1198
1199 /* Add a cachel for the given face to the given window's cache. */
1200
1201 static void
1202 add_face_cachel (struct window *w, Lisp_Object face)
1203 {
1204   int must_finish_frobbing = ! WINDOW_FACE_CACHEL (w, DEFAULT_INDEX);
1205   struct face_cachel new_cachel;
1206   Lisp_Object domain;
1207
1208   reset_face_cachel (&new_cachel);
1209   XSETWINDOW (domain, w);
1210   update_face_cachel_data (&new_cachel, domain, face);
1211   Dynarr_add (w->face_cachels, new_cachel);
1212
1213   /* The face's background pixmap have not yet been frobbed (see comment
1214      int update_face_cachel_data), so we have to do it now */
1215   if (must_finish_frobbing)
1216     {
1217       int default_face = EQ (face, Vdefault_face);
1218       struct face_cachel *cachel
1219         = Dynarr_atp (w->face_cachels, Dynarr_length (w->face_cachels) - 1);
1220
1221       FROB (background_pixmap);
1222       MAYBE_UNFROB_BACKGROUND_PIXMAP;
1223     }
1224 }
1225
1226 /* Called when the updated flag has been cleared on a cachel.
1227    This function returns 1 if the caller must finish the update (see comment
1228    below), 0 otherwise.
1229 */
1230
1231 void
1232 update_face_cachel_data (struct face_cachel *cachel,
1233                          Lisp_Object domain,
1234                          Lisp_Object face)
1235 {
1236   if (XFACE (face)->dirty || UNBOUNDP (cachel->face))
1237     {
1238       int default_face = EQ (face, Vdefault_face);
1239       cachel->face = face;
1240
1241       /* We normally only set the _specified flags if the value was
1242          actually bound.  The exception is for the default face where
1243          we always set it since it is the ultimate fallback. */
1244
1245       FROB (foreground);
1246       FROB (background);
1247       FROB (display_table);
1248
1249       /* #### WARNING: the background pixmap property of faces is currently
1250          the only one dealing with images. The problem we have here is that
1251          frobbing the background pixmap might lead to image instantiation
1252          which in turn might require that the cache we're building be up to
1253          date, hence a crash. Here's a typical scenario of this:
1254
1255          - a new window is created and it's face cache elements are
1256          initialized through a call to reset_face_cachels[1]. At that point,
1257          the cache for the default and modeline faces (normaly taken care of
1258          by redisplay itself) are null.
1259          - the default face has a background pixmap which needs to be
1260          instantiated right here, as a consequence of cache initialization.
1261          - the background pixmap image happens to be instantiated as a string
1262          (this happens on tty's for instance).
1263          - In order to do this, we need to compute the string geometry.
1264          - In order to do this, we might have to access the window's default
1265          face cache. But this is the cache we're building right now, it is
1266          null.
1267          - BARF !!!!!
1268
1269          To sum up, this means that it is in general unsafe to instantiate
1270          images before face cache updating is complete (appart from image
1271          related face attributes). The solution we use below is to actually
1272          detect whether we're building the window's face_cachels for the first
1273          time, and simply NOT frob the background pixmap in that case. If
1274          other image-related face attributes are ever implemented, they should
1275          be protected the same way right here.
1276
1277          One note:
1278          * See comment in `default_face_font_info' in face.c. Who wrote it ?
1279          Maybe we have the begining of an answer here ?
1280
1281          Footnotes:
1282          [1] See comment at the top of `allocate_window' in window.c.
1283
1284          -- didier
1285       */
1286       if (! WINDOWP (domain)
1287           || WINDOW_FACE_CACHEL (DOMAIN_XWINDOW (domain), DEFAULT_INDEX))
1288         {
1289           FROB (background_pixmap);
1290           MAYBE_UNFROB_BACKGROUND_PIXMAP;
1291         }
1292 #undef FROB
1293 #undef MAYBE_UNFROB_BACKGROUND_PIXMAP
1294
1295       ensure_face_cachel_contains_charset (cachel, domain, Vcharset_ascii);
1296
1297 #define FROB(field)                                                          \
1298   do {                                                                       \
1299     Lisp_Object new_val =                                                    \
1300       FACE_PROPERTY_INSTANCE (face, Q##field, domain, 1, Qzero);             \
1301     int bound = 1;                                                           \
1302     unsigned int new_val_int;                                                \
1303     if (UNBOUNDP (new_val))                                                  \
1304       {                                                                      \
1305         bound = 0;                                                           \
1306         new_val = FACE_PROPERTY_INSTANCE (face, Q##field, domain, 0, Qzero); \
1307       }                                                                      \
1308     new_val_int = EQ (new_val, Qt);                                          \
1309     if (cachel->field != new_val_int)                                        \
1310       {                                                                      \
1311         cachel->field = new_val_int;                                         \
1312         cachel->dirty = 1;                                                   \
1313       }                                                                      \
1314     cachel->field##_specified = bound;                                       \
1315   } while (0)
1316
1317       FROB (underline);
1318       FROB (strikethru);
1319       FROB (highlight);
1320       FROB (dim);
1321       FROB (reverse);
1322       FROB (blinking);
1323 #undef FROB
1324     }
1325
1326   cachel->updated = 1;
1327 }
1328
1329 /* Merge the cachel identified by FINDEX in window W into the given
1330    cachel. */
1331
1332 static void
1333 merge_face_cachel_data (struct window *w, face_index findex,
1334                         struct face_cachel *cachel)
1335 {
1336 #define FINDEX_FIELD(field)                                             \
1337   Dynarr_atp (w->face_cachels, findex)->field
1338
1339 #define FROB(field)                                                     \
1340   do {                                                                  \
1341     if (!cachel->field##_specified && FINDEX_FIELD (field##_specified)) \
1342       {                                                                 \
1343         cachel->field = FINDEX_FIELD (field);                           \
1344         cachel->field##_specified = 1;                                  \
1345         cachel->dirty = 1;                                              \
1346       }                                                                 \
1347   } while (0)
1348
1349   FROB (foreground);
1350   FROB (background);
1351   FROB (display_table);
1352   FROB (background_pixmap);
1353   FROB (underline);
1354   FROB (strikethru);
1355   FROB (highlight);
1356   FROB (dim);
1357   FROB (reverse);
1358   FROB (blinking);
1359   /* And do ASCII, of course. */
1360   {
1361     int offs = LEADING_BYTE_ASCII - MIN_LEADING_BYTE;
1362
1363     if (!cachel->font_specified[offs] && FINDEX_FIELD (font_specified[offs]))
1364       {
1365         cachel->font[offs] = FINDEX_FIELD (font[offs]);
1366         cachel->font_specified[offs] = 1;
1367         cachel->dirty = 1;
1368       }
1369   }
1370
1371 #undef FROB
1372 #undef FINDEX_FIELD
1373
1374   cachel->updated = 1;
1375 }
1376
1377 /* Initialize a cachel. */
1378
1379 void
1380 reset_face_cachel (struct face_cachel *cachel)
1381 {
1382   xzero (*cachel);
1383   cachel->face = Qunbound;
1384   cachel->nfaces = 0;
1385   cachel->merged_faces = 0;
1386   cachel->foreground = Qunbound;
1387   cachel->background = Qunbound;
1388   {
1389     int i;
1390
1391     for (i = 0; i < NUM_LEADING_BYTES; i++)
1392       cachel->font[i] = Qunbound;
1393   }
1394   cachel->display_table = Qunbound;
1395   cachel->background_pixmap = Qunbound;
1396 }
1397
1398 /* Retrieve the index to a cachel for window W that corresponds to
1399    the specified face.  If necessary, add a new element to the
1400    cache. */
1401
1402 face_index
1403 get_builtin_face_cache_index (struct window *w, Lisp_Object face)
1404 {
1405   int elt;
1406
1407   if (noninteractive)
1408     return 0;
1409
1410   for (elt = 0; elt < Dynarr_length (w->face_cachels); elt++)
1411     {
1412       struct face_cachel *cachel = WINDOW_FACE_CACHEL (w, elt);
1413
1414       if (EQ (cachel->face, face))
1415         {
1416           Lisp_Object window;
1417           XSETWINDOW (window, w);
1418           if (!cachel->updated)
1419             update_face_cachel_data (cachel, window, face);
1420           return elt;
1421         }
1422     }
1423
1424   /* If we didn't find the face, add it and then return its index. */
1425   add_face_cachel (w, face);
1426   return elt;
1427 }
1428
1429 void
1430 reset_face_cachels (struct window *w)
1431 {
1432   /* #### Not initialized in batch mode for the stream device. */
1433   if (w->face_cachels)
1434     {
1435       int i;
1436
1437       for (i = 0; i < Dynarr_length (w->face_cachels); i++)
1438         {
1439           struct face_cachel *cachel = Dynarr_atp (w->face_cachels, i);
1440           if (cachel->merged_faces)
1441             Dynarr_free (cachel->merged_faces);
1442         }
1443       Dynarr_reset (w->face_cachels);
1444       get_builtin_face_cache_index (w, Vdefault_face);
1445       get_builtin_face_cache_index (w, Vmodeline_face);
1446       XFRAME (w->frame)->window_face_cache_reset = 1;
1447     }
1448 }
1449
1450 void
1451 mark_face_cachels_as_clean (struct window *w)
1452 {
1453   int elt;
1454
1455   for (elt = 0; elt < Dynarr_length (w->face_cachels); elt++)
1456     Dynarr_atp (w->face_cachels, elt)->dirty = 0;
1457 }
1458
1459 void
1460 mark_face_cachels_as_not_updated (struct window *w)
1461 {
1462   int elt;
1463
1464   for (elt = 0; elt < Dynarr_length (w->face_cachels); elt++)
1465     {
1466       struct face_cachel *cachel = Dynarr_atp (w->face_cachels, elt);
1467       int i;
1468
1469       cachel->updated = 0;
1470       for (i = 0; i < NUM_LEADING_BYTES; i++)
1471         cachel->font_updated[i] = 0;
1472     }
1473 }
1474
1475 #ifdef MEMORY_USAGE_STATS
1476
1477 int
1478 compute_face_cachel_usage (face_cachel_dynarr *face_cachels,
1479                            struct overhead_stats *ovstats)
1480 {
1481   int total = 0;
1482
1483   if (face_cachels)
1484     {
1485       int i;
1486
1487       total += Dynarr_memory_usage (face_cachels, ovstats);
1488       for (i = 0; i < Dynarr_length (face_cachels); i++)
1489         {
1490           int_dynarr *merged = Dynarr_at (face_cachels, i).merged_faces;
1491           if (merged)
1492             total += Dynarr_memory_usage (merged, ovstats);
1493         }
1494     }
1495
1496   return total;
1497 }
1498
1499 #endif /* MEMORY_USAGE_STATS */
1500
1501 \f
1502 /*****************************************************************************
1503  *                             merged face functions                         *
1504  *****************************************************************************/
1505
1506 /* Compare two merged face cachels to determine whether we have to add
1507    a new entry to the face cache.
1508
1509    Note that we do not compare the attributes, but just the faces the
1510    cachels are based on.  If they are the same, then the cachels certainly
1511    ought to have the same attributes, except in the case where fonts
1512    for different charsets have been determined in the two -- and in that
1513    case this difference is fine. */
1514
1515 static int
1516 compare_merged_face_cachels (struct face_cachel *cachel1,
1517                              struct face_cachel *cachel2)
1518 {
1519   int i;
1520
1521   if (!EQ (cachel1->face, cachel2->face)
1522       || cachel1->nfaces != cachel2->nfaces)
1523     return 0;
1524
1525   for (i = 0; i < cachel1->nfaces; i++)
1526     if (FACE_CACHEL_FINDEX_UNSAFE (cachel1, i)
1527         != FACE_CACHEL_FINDEX_UNSAFE (cachel2, i))
1528       return 0;
1529
1530   return 1;
1531 }
1532
1533 /* Retrieve the index to a cachel for window W that corresponds to
1534    the specified cachel.  If necessary, add a new element to the
1535    cache.  This is similar to get_builtin_face_cache_index() but
1536    is intended for merged cachels rather than for cachels representing
1537    just a face.
1538
1539    Note that a merged cachel for just one face is not the same as
1540    the simple cachel for that face, because it is also merged with
1541    the default face. */
1542
1543 static face_index
1544 get_merged_face_cache_index (struct window *w,
1545                              struct face_cachel *merged_cachel)
1546 {
1547   int elt;
1548   int cache_size = Dynarr_length (w->face_cachels);
1549
1550   for (elt = 0; elt < cache_size; elt++)
1551     {
1552       struct face_cachel *cachel =
1553         Dynarr_atp (w->face_cachels, elt);
1554
1555       if (compare_merged_face_cachels (cachel, merged_cachel))
1556         return elt;
1557     }
1558
1559   /* We didn't find it so add this instance to the cache. */
1560   merged_cachel->updated = 1;
1561   merged_cachel->dirty = 1;
1562   Dynarr_add (w->face_cachels, *merged_cachel);
1563   return cache_size;
1564 }
1565
1566 face_index
1567 get_extent_fragment_face_cache_index (struct window *w,
1568                                       struct extent_fragment *ef)
1569 {
1570   struct face_cachel cachel;
1571   int len = Dynarr_length (ef->extents);
1572   face_index findex = 0;
1573   Lisp_Object window;
1574   XSETWINDOW (window, w);
1575
1576   /* Optimize the default case. */
1577   if (len == 0)
1578     return DEFAULT_INDEX;
1579   else
1580     {
1581       int i;
1582
1583       /* Merge the faces of the extents together in order. */
1584
1585       reset_face_cachel (&cachel);
1586
1587       for (i = len - 1; i >= 0; i--)
1588         {
1589           EXTENT current = Dynarr_at (ef->extents, i);
1590           int has_findex = 0;
1591           Lisp_Object face = extent_face (current);
1592
1593           if (FACEP (face))
1594             {
1595               findex = get_builtin_face_cache_index (w, face);
1596               has_findex = 1;
1597               merge_face_cachel_data (w, findex, &cachel);
1598             }
1599           /* remember, we're called from within redisplay
1600              so we can't error. */
1601           else while (CONSP (face))
1602             {
1603               Lisp_Object one_face = XCAR (face);
1604               if (FACEP (one_face))
1605                 {
1606                   findex = get_builtin_face_cache_index (w, one_face);
1607                   merge_face_cachel_data (w, findex, &cachel);
1608
1609                   /* code duplication here but there's no clean
1610                      way to avoid it. */
1611                   if (cachel.nfaces >= NUM_STATIC_CACHEL_FACES)
1612                     {
1613                       if (!cachel.merged_faces)
1614                         cachel.merged_faces = Dynarr_new (int);
1615                       Dynarr_add (cachel.merged_faces, findex);
1616                     }
1617                   else
1618                     cachel.merged_faces_static[cachel.nfaces] = findex;
1619                   cachel.nfaces++;
1620                 }
1621               face = XCDR (face);
1622             }
1623
1624           if (has_findex)
1625             {
1626               if (cachel.nfaces >= NUM_STATIC_CACHEL_FACES)
1627                 {
1628                   if (!cachel.merged_faces)
1629                     cachel.merged_faces = Dynarr_new (int);
1630                   Dynarr_add (cachel.merged_faces, findex);
1631                 }
1632               else
1633                 cachel.merged_faces_static[cachel.nfaces] = findex;
1634               cachel.nfaces++;
1635             }
1636         }
1637
1638       /* Now finally merge in the default face. */
1639       findex = get_builtin_face_cache_index (w, Vdefault_face);
1640       merge_face_cachel_data (w, findex, &cachel);
1641
1642       findex = get_merged_face_cache_index (w, &cachel);
1643       if (cachel.merged_faces &&
1644           /* merged_faces did not get stored and available via return value */
1645           Dynarr_at (w->face_cachels, findex).merged_faces !=
1646           cachel.merged_faces)
1647         {
1648           Dynarr_free (cachel.merged_faces);
1649           cachel.merged_faces = 0;
1650         }
1651       return findex;
1652     }
1653 }
1654
1655 \f
1656 /*****************************************************************************
1657  interface functions
1658  ****************************************************************************/
1659
1660 static void
1661 update_EmacsFrame (Lisp_Object frame, Lisp_Object name)
1662 {
1663   struct frame *frm = XFRAME (frame);
1664
1665   if (EQ (name, Qfont))
1666     MARK_FRAME_SIZE_SLIPPED (frm);
1667
1668   MAYBE_FRAMEMETH (frm, update_frame_external_traits, (frm, name));
1669 }
1670
1671 static void
1672 update_EmacsFrames (Lisp_Object locale, Lisp_Object name)
1673 {
1674   if (FRAMEP (locale))
1675     {
1676       update_EmacsFrame (locale, name);
1677     }
1678   else if (DEVICEP (locale))
1679     {
1680       Lisp_Object frmcons;
1681
1682       DEVICE_FRAME_LOOP (frmcons, XDEVICE (locale))
1683         update_EmacsFrame (XCAR (frmcons), name);
1684     }
1685   else if (EQ (locale, Qglobal) || EQ (locale, Qfallback))
1686     {
1687       Lisp_Object frmcons, devcons, concons;
1688
1689       FRAME_LOOP_NO_BREAK (frmcons, devcons, concons)
1690         update_EmacsFrame (XCAR (frmcons), name);
1691     }
1692 }
1693
1694 void
1695 update_frame_face_values (struct frame *f)
1696 {
1697   Lisp_Object frm;
1698
1699   XSETFRAME (frm, f);
1700   update_EmacsFrame (frm, Qforeground);
1701   update_EmacsFrame (frm, Qbackground);
1702   update_EmacsFrame (frm, Qfont);
1703 }
1704
1705 void
1706 face_property_was_changed (Lisp_Object face, Lisp_Object property,
1707                            Lisp_Object locale)
1708 {
1709   int default_face = EQ (face, Vdefault_face);
1710
1711   /* If the locale could affect the frame value, then call
1712      update_EmacsFrames just in case. */
1713   if (default_face &&
1714       (EQ (property, Qforeground) ||
1715        EQ (property, Qbackground) ||
1716        EQ (property, Qfont)))
1717     update_EmacsFrames (locale, property);
1718
1719   if (WINDOWP (locale))
1720     {
1721       MARK_FRAME_FACES_CHANGED (XFRAME (XWINDOW (locale)->frame));
1722     }
1723   else if (FRAMEP (locale))
1724     {
1725       MARK_FRAME_FACES_CHANGED (XFRAME (locale));
1726     }
1727   else if (DEVICEP (locale))
1728     {
1729       MARK_DEVICE_FRAMES_FACES_CHANGED (XDEVICE (locale));
1730     }
1731   else
1732     {
1733       Lisp_Object devcons, concons;
1734       DEVICE_LOOP_NO_BREAK (devcons, concons)
1735         MARK_DEVICE_FRAMES_FACES_CHANGED (XDEVICE (XCAR (devcons)));
1736     }
1737
1738   /*
1739    * This call to update_faces_inheritance isn't needed and makes
1740    * creating and modifying faces _very_ slow.  The point of
1741    * update_face_inheritances is to find all faces that inherit
1742    * directly from this face property and set the specifier "dirty"
1743    * flag on the corresponding specifier.  This forces recaching of
1744    * cached specifier values in frame and window struct slots.  But
1745    * currently no face properties are cached in frame and window
1746    * struct slots, so calling this function does nothing useful!
1747    *
1748    * Further, since update_faces_inheritance maps over the whole
1749    * face table every time it is called, it gets terribly slow when
1750    * there are many faces.  Creating 500 faces on a 50Mhz 486 took
1751    * 433 seconds when update_faces_inheritance was called.  With the
1752    * call commented out, creating those same 500 faces took 0.72
1753    * seconds.
1754    */
1755   /* update_faces_inheritance (face, property);*/
1756   XFACE (face)->dirty = 1;
1757 }
1758
1759 DEFUN ("copy-face", Fcopy_face, 2, 6, 0, /*
1760 Define and return a new face which is a copy of an existing one,
1761 or makes an already-existing face be exactly like another.
1762 LOCALE, TAG-SET, EXACT-P, and HOW-TO-ADD are as in `copy-specifier'.
1763 */
1764        (old_face, new_name, locale, tag_set, exact_p, how_to_add))
1765 {
1766   Lisp_Face *fold, *fnew;
1767   Lisp_Object new_face = Qnil;
1768   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
1769
1770   old_face = Fget_face (old_face);
1771
1772   /* We GCPRO old_face because it might be temporary, and GCing could
1773      occur in various places below. */
1774   GCPRO4 (tag_set, locale, old_face, new_face);
1775   /* check validity of how_to_add now. */
1776   decode_how_to_add_specification (how_to_add);
1777   /* and of tag_set. */
1778   tag_set = decode_specifier_tag_set (tag_set);
1779   /* and of locale. */
1780   locale = decode_locale_list (locale);
1781
1782   new_face = Ffind_face (new_name);
1783   if (NILP (new_face))
1784     {
1785       Lisp_Object temp;
1786
1787       CHECK_SYMBOL (new_name);
1788
1789       /* Create the new face with the same status as the old face. */
1790       temp = (NILP (Fgethash (old_face, Vtemporary_faces_cache, Qnil))
1791               ? Qnil
1792               : Qt);
1793
1794       new_face = Fmake_face (new_name, Qnil, temp);
1795     }
1796
1797   fold = XFACE (old_face);
1798   fnew = XFACE (new_face);
1799
1800 #define COPY_PROPERTY(property) \
1801   Fcopy_specifier (fold->property, fnew->property, \
1802                    locale, tag_set, exact_p, how_to_add);
1803
1804   COPY_PROPERTY (foreground);
1805   COPY_PROPERTY (background);
1806   COPY_PROPERTY (font);
1807   COPY_PROPERTY (display_table);
1808   COPY_PROPERTY (background_pixmap);
1809   COPY_PROPERTY (underline);
1810   COPY_PROPERTY (strikethru);
1811   COPY_PROPERTY (highlight);
1812   COPY_PROPERTY (dim);
1813   COPY_PROPERTY (blinking);
1814   COPY_PROPERTY (reverse);
1815 #undef COPY_PROPERTY
1816   /* #### should it copy the individual specifiers, if they exist? */
1817   fnew->plist = Fcopy_sequence (fold->plist);
1818
1819   UNGCPRO;
1820
1821   return new_name;
1822 }
1823
1824 \f
1825 void
1826 syms_of_faces (void)
1827 {
1828   INIT_LRECORD_IMPLEMENTATION (face);
1829
1830   /* Qdefault, Qwidget, Qleft_margin, Qright_margin defined in general.c */
1831   defsymbol (&Qmodeline, "modeline");
1832   defsymbol (&Qgui_element, "gui-element");
1833   defsymbol (&Qtext_cursor, "text-cursor");
1834   defsymbol (&Qvertical_divider, "vertical-divider");
1835
1836   DEFSUBR (Ffacep);
1837   DEFSUBR (Ffind_face);
1838   DEFSUBR (Fget_face);
1839   DEFSUBR (Fface_name);
1840   DEFSUBR (Fbuilt_in_face_specifiers);
1841   DEFSUBR (Fface_list);
1842   DEFSUBR (Fmake_face);
1843   DEFSUBR (Fcopy_face);
1844
1845   defsymbol (&Qfacep, "facep");
1846   defsymbol (&Qforeground, "foreground");
1847   defsymbol (&Qbackground, "background");
1848   /* Qfont defined in general.c */
1849   defsymbol (&Qdisplay_table, "display-table");
1850   defsymbol (&Qbackground_pixmap, "background-pixmap");
1851   defsymbol (&Qunderline, "underline");
1852   defsymbol (&Qstrikethru, "strikethru");
1853   /* Qhighlight, Qreverse defined in general.c */
1854   defsymbol (&Qdim, "dim");
1855   defsymbol (&Qblinking, "blinking");
1856
1857   defsymbol (&Qinit_face_from_resources, "init-face-from-resources");
1858   defsymbol (&Qinit_global_faces, "init-global-faces");
1859   defsymbol (&Qinit_device_faces, "init-device-faces");
1860   defsymbol (&Qinit_frame_faces, "init-frame-faces");
1861 }
1862
1863 void
1864 structure_type_create_faces (void)
1865 {
1866   struct structure_type *st;
1867
1868   st = define_structure_type (Qface, face_validate, face_instantiate);
1869
1870   define_structure_type_keyword (st, Qname, face_name_validate);
1871 }
1872
1873 void
1874 vars_of_faces (void)
1875 {
1876   staticpro (&Vpermanent_faces_cache);
1877   Vpermanent_faces_cache = Qnil;
1878   staticpro (&Vtemporary_faces_cache);
1879   Vtemporary_faces_cache = Qnil;
1880
1881   staticpro (&Vdefault_face);
1882   Vdefault_face = Qnil;
1883   staticpro (&Vgui_element_face);
1884   Vgui_element_face = Qnil;
1885   staticpro (&Vwidget_face);
1886   Vwidget_face = Qnil;
1887   staticpro (&Vmodeline_face);
1888   Vmodeline_face = Qnil;
1889   staticpro (&Vtoolbar_face);
1890   Vtoolbar_face = Qnil;
1891
1892   staticpro (&Vvertical_divider_face);
1893   Vvertical_divider_face = Qnil;
1894   staticpro (&Vleft_margin_face);
1895   Vleft_margin_face = Qnil;
1896   staticpro (&Vright_margin_face);
1897   Vright_margin_face = Qnil;
1898   staticpro (&Vtext_cursor_face);
1899   Vtext_cursor_face = Qnil;
1900   staticpro (&Vpointer_face);
1901   Vpointer_face = Qnil;
1902
1903   {
1904     Lisp_Object syms[20];
1905     int n = 0;
1906
1907     syms[n++] = Qforeground;
1908     syms[n++] = Qbackground;
1909     syms[n++] = Qfont;
1910     syms[n++] = Qdisplay_table;
1911     syms[n++] = Qbackground_pixmap;
1912     syms[n++] = Qunderline;
1913     syms[n++] = Qstrikethru;
1914     syms[n++] = Qhighlight;
1915     syms[n++] = Qdim;
1916     syms[n++] = Qblinking;
1917     syms[n++] = Qreverse;
1918
1919     Vbuilt_in_face_specifiers = Flist (n, syms);
1920     staticpro (&Vbuilt_in_face_specifiers);
1921   }
1922 }
1923
1924 void
1925 complex_vars_of_faces (void)
1926 {
1927   Vpermanent_faces_cache =
1928     make_lisp_hash_table (10, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
1929   Vtemporary_faces_cache =
1930     make_lisp_hash_table (0, HASH_TABLE_WEAK, HASH_TABLE_EQ);
1931
1932   /* Create the default face now so we know what it is immediately. */
1933
1934   Vdefault_face = Qnil; /* so that Fmake_face() doesn't set up a bogus
1935                            default value */
1936   Vdefault_face = Fmake_face (Qdefault, build_string ("default face"),
1937                               Qnil);
1938
1939   /* Provide some last-resort fallbacks to avoid utter fuckage if
1940      someone provides invalid values for the global specifications. */
1941
1942   {
1943     Lisp_Object fg_fb = Qnil, bg_fb = Qnil;
1944
1945 #ifdef HAVE_GTK
1946     fg_fb = acons (list1 (Qgtk), build_string ("black"), fg_fb);
1947     bg_fb = acons (list1 (Qgtk), build_string ("white"), bg_fb);
1948 #endif
1949 #ifdef HAVE_X_WINDOWS
1950     fg_fb = acons (list1 (Qx), build_string ("black"), fg_fb);
1951     bg_fb = acons (list1 (Qx), build_string ("white"), bg_fb);
1952 #endif
1953 #ifdef HAVE_TTY
1954     fg_fb = acons (list1 (Qtty), Fvector (0, 0), fg_fb);
1955     bg_fb = acons (list1 (Qtty), Fvector (0, 0), bg_fb);
1956 #endif
1957 #ifdef HAVE_MS_WINDOWS
1958     fg_fb = acons (list1 (Qmsprinter), build_string ("black"), fg_fb);
1959     bg_fb = acons (list1 (Qmsprinter), build_string ("white"), bg_fb);
1960     fg_fb = acons (list1 (Qmswindows), build_string ("black"), fg_fb);
1961     bg_fb = acons (list1 (Qmswindows), build_string ("white"), bg_fb);
1962 #endif
1963     set_specifier_fallback (Fget (Vdefault_face, Qforeground, Qnil), fg_fb);
1964     set_specifier_fallback (Fget (Vdefault_face, Qbackground, Qnil), bg_fb);
1965   }
1966
1967   /* #### We may want to have different fallback values if NeXTstep
1968      support is compiled in. */
1969   {
1970     Lisp_Object inst_list = Qnil;
1971
1972 #if defined(HAVE_X_WINDOWS) || defined(HAVE_GTK)
1973     /* This is kind of ugly because stephen wanted this to be CPP
1974     ** identical to the old version, at least for the initial
1975     ** checkin
1976     **
1977     ** WMP March 9, 2001
1978     */
1979
1980     /* The same gory list from x-faces.el.
1981        (#### Perhaps we should remove the stuff from x-faces.el
1982        and only depend on this stuff here?  That should work.)
1983      */
1984     const char *fonts[] =
1985     {
1986       "-*-courier-medium-r-*-*-*-120-*-*-*-*-iso8859-*",
1987       "-*-courier-medium-r-*-*-*-120-*-*-*-*-iso8859-*",
1988       "-*-courier-*-r-*-*-*-120-*-*-*-*-iso8859-*",
1989       "-*-*-medium-r-*-*-*-120-*-*-m-*-iso8859-*",
1990       "-*-*-medium-r-*-*-*-120-*-*-c-*-iso8859-*",
1991       "-*-*-*-r-*-*-*-120-*-*-m-*-iso8859-*",
1992       "-*-*-*-r-*-*-*-120-*-*-c-*-iso8859-*",
1993       "-*-*-*-r-*-*-*-120-*-*-*-*-iso8859-*",
1994       "-*-*-medium-r-*-*-*-120-*-*-m-*-*-*",
1995       "-*-*-medium-r-*-*-*-120-*-*-c-*-*-*",
1996       "-*-*-*-r-*-*-*-120-*-*-m-*-*-*",
1997       "-*-*-*-r-*-*-*-120-*-*-c-*-*-*",
1998       "-*-*-*-r-*-*-*-120-*-*-*-*-*-*",
1999       "-*-*-*-*-*-*-*-120-*-*-*-*-*-*",
2000       "*"
2001     };
2002     const char **fontptr;
2003
2004 #ifdef HAVE_X_WINDOWS
2005     for (fontptr = fonts + countof(fonts) - 1; fontptr >= fonts; fontptr--)
2006       inst_list = Fcons (Fcons (list1 (Qx), build_string (*fontptr)),
2007                          inst_list);
2008 #endif /* HAVE_X_WINDOWS */
2009
2010 #ifdef HAVE_GTK
2011     for (fontptr = fonts + countof(fonts) - 1; fontptr >= fonts; fontptr--)
2012       inst_list = Fcons (Fcons (list1 (Qgtk), build_string (*fontptr)),
2013                          inst_list);
2014 #endif /* HAVE_GTK */
2015 #endif /* HAVE_X_WINDOWS || HAVE_GTK */
2016
2017
2018 #ifdef HAVE_TTY
2019     inst_list = Fcons (Fcons (list1 (Qtty), build_string ("normal")),
2020                        inst_list);
2021 #endif /* HAVE_TTY */
2022 #ifdef HAVE_MS_WINDOWS
2023     /* Fixedsys does not exist for printers */
2024     inst_list = Fcons (Fcons (list1 (Qmsprinter),
2025                               build_string ("Courier:Regular:10::Western")), inst_list);
2026     inst_list = Fcons (Fcons (list1 (Qmsprinter),
2027                               build_string ("Courier New:Regular:10::Western")), inst_list);
2028
2029     inst_list = Fcons (Fcons (list1 (Qmswindows),
2030                               build_string ("Fixedsys:Regular:9::Western")), inst_list);
2031     inst_list = Fcons (Fcons (list1 (Qmswindows),
2032                               build_string ("Courier:Regular:10::Western")), inst_list);
2033     inst_list = Fcons (Fcons (list1 (Qmswindows),
2034                               build_string ("Courier New:Regular:10::Western")), inst_list);
2035 #endif /* HAVE_MS_WINDOWS */
2036     set_specifier_fallback (Fget (Vdefault_face, Qfont, Qnil), inst_list);
2037   }
2038
2039   set_specifier_fallback (Fget (Vdefault_face, Qunderline, Qnil),
2040                          list1 (Fcons (Qnil, Qnil)));
2041   set_specifier_fallback (Fget (Vdefault_face, Qstrikethru, Qnil),
2042                          list1 (Fcons (Qnil, Qnil)));
2043   set_specifier_fallback (Fget (Vdefault_face, Qhighlight, Qnil),
2044                          list1 (Fcons (Qnil, Qnil)));
2045   set_specifier_fallback (Fget (Vdefault_face, Qdim, Qnil),
2046                          list1 (Fcons (Qnil, Qnil)));
2047   set_specifier_fallback (Fget (Vdefault_face, Qblinking, Qnil),
2048                          list1 (Fcons (Qnil, Qnil)));
2049   set_specifier_fallback (Fget (Vdefault_face, Qreverse, Qnil),
2050                          list1 (Fcons (Qnil, Qnil)));
2051
2052   /* gui-element is the parent face of all gui elements such as
2053      modeline, vertical divider and toolbar. */
2054   Vgui_element_face = Fmake_face (Qgui_element,
2055                                   build_string ("gui element face"),
2056                                   Qnil);
2057
2058   /* Provide some last-resort fallbacks for gui-element face which
2059      mustn't default to default. */
2060   {
2061     Lisp_Object fg_fb = Qnil, bg_fb = Qnil;
2062
2063 #ifdef HAVE_GTK
2064     /* We need to put something in there, or error checking gets
2065        #%!@#ed up before the styles are set, which override the
2066        fallbacks. */
2067     fg_fb = acons (list1 (Qgtk), build_string ("black"), fg_fb);
2068     bg_fb = acons (list1 (Qgtk), build_string ("Gray80"), bg_fb);
2069 #endif
2070 #ifdef HAVE_X_WINDOWS
2071     fg_fb = acons (list1 (Qx), build_string ("black"), fg_fb);
2072     bg_fb = acons (list1 (Qx), build_string ("Gray80"), bg_fb);
2073 #endif
2074 #ifdef HAVE_TTY
2075     fg_fb = acons (list1 (Qtty), Fvector (0, 0), fg_fb);
2076     bg_fb = acons (list1 (Qtty), Fvector (0, 0), bg_fb);
2077 #endif
2078 #ifdef HAVE_MS_WINDOWS
2079     fg_fb = acons (list1 (Qmsprinter), build_string ("black"), fg_fb);
2080     bg_fb = acons (list1 (Qmsprinter), build_string ("white"), bg_fb);
2081     fg_fb = acons (list1 (Qmswindows), build_string ("black"), fg_fb);
2082     bg_fb = acons (list1 (Qmswindows), build_string ("Gray75"), bg_fb);
2083 #endif
2084     set_specifier_fallback (Fget (Vgui_element_face, Qforeground, Qnil), fg_fb);
2085     set_specifier_fallback (Fget (Vgui_element_face, Qbackground, Qnil), bg_fb);
2086   }
2087
2088   /* Now create the other faces that redisplay needs to refer to
2089      directly.  We could create them in Lisp but it's simpler this
2090      way since we need to get them anyway. */
2091
2092   /* modeline is gui element. */
2093   Vmodeline_face = Fmake_face (Qmodeline, build_string ("modeline face"),
2094                                Qnil);
2095
2096   set_specifier_fallback (Fget (Vmodeline_face, Qforeground, Qunbound),
2097                           Fget (Vgui_element_face, Qforeground, Qunbound));
2098   set_specifier_fallback (Fget (Vmodeline_face, Qbackground, Qunbound),
2099                           Fget (Vgui_element_face, Qbackground, Qunbound));
2100   set_specifier_fallback (Fget (Vmodeline_face, Qbackground_pixmap, Qnil),
2101                           Fget (Vgui_element_face, Qbackground_pixmap,
2102                                 Qunbound));
2103
2104   /* toolbar is another gui element */
2105   Vtoolbar_face = Fmake_face (Qtoolbar,
2106                               build_string ("toolbar face"),
2107                               Qnil);
2108   set_specifier_fallback (Fget (Vtoolbar_face, Qforeground, Qunbound),
2109                           Fget (Vgui_element_face, Qforeground, Qunbound));
2110   set_specifier_fallback (Fget (Vtoolbar_face, Qbackground, Qunbound),
2111                           Fget (Vgui_element_face, Qbackground, Qunbound));
2112   set_specifier_fallback (Fget (Vtoolbar_face, Qbackground_pixmap, Qnil),
2113                           Fget (Vgui_element_face, Qbackground_pixmap,
2114                                 Qunbound));
2115
2116   /* vertical divider is another gui element */
2117   Vvertical_divider_face = Fmake_face (Qvertical_divider,
2118                                        build_string ("vertical divider face"),
2119                                        Qnil);
2120
2121   set_specifier_fallback (Fget (Vvertical_divider_face, Qforeground, Qunbound),
2122                           Fget (Vgui_element_face, Qforeground, Qunbound));
2123   set_specifier_fallback (Fget (Vvertical_divider_face, Qbackground, Qunbound),
2124                           Fget (Vgui_element_face, Qbackground, Qunbound));
2125   set_specifier_fallback (Fget (Vvertical_divider_face, Qbackground_pixmap,
2126                                 Qunbound),
2127                           Fget (Vgui_element_face, Qbackground_pixmap,
2128                                 Qunbound));
2129
2130   /* widget is another gui element */
2131   Vwidget_face = Fmake_face (Qwidget,
2132                              build_string ("widget face"),
2133                              Qnil);
2134   set_specifier_fallback (Fget (Vwidget_face, Qfont, Qunbound),
2135                           Fget (Vgui_element_face, Qfont, Qunbound));
2136   set_specifier_fallback (Fget (Vwidget_face, Qforeground, Qunbound),
2137                           Fget (Vgui_element_face, Qforeground, Qunbound));
2138   set_specifier_fallback (Fget (Vwidget_face, Qbackground, Qunbound),
2139                           Fget (Vgui_element_face, Qbackground, Qunbound));
2140   /* We don't want widgets to have a default background pixmap. */
2141
2142   Vleft_margin_face = Fmake_face (Qleft_margin,
2143                                   build_string ("left margin face"),
2144                                   Qnil);
2145   Vright_margin_face = Fmake_face (Qright_margin,
2146                                    build_string ("right margin face"),
2147                                    Qnil);
2148   Vtext_cursor_face = Fmake_face (Qtext_cursor,
2149                                   build_string ("face for text cursor"),
2150                                   Qnil);
2151   Vpointer_face =
2152     Fmake_face (Qpointer,
2153                 build_string
2154                 ("face for foreground/background colors of mouse pointer"),
2155                 Qnil);
2156 }