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.
7 This file is part of XEmacs.
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
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
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. */
24 /* Synched up with: Not in FSF. */
26 /* Written by Chuck Thompson and Ben Wing,
27 based loosely on old face code by Jamie Zawinski. */
40 #include "specifier.h"
44 Lisp_Object Qforeground, Qbackground, Qdisplay_table;
45 Lisp_Object Qbackground_pixmap, Qunderline, Qdim;
46 Lisp_Object Qblinking, Qstrikethru;
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;
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;
60 /* Qdefault, Qhighlight, Qleft_margin, Qright_margin defined in general.c */
61 Lisp_Object Qmodeline, Qgui_element, Qtext_cursor, Qvertical_divider;
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;
70 Lisp_Object Vbuilt_in_face_specifiers;
75 mark_face (Lisp_Object obj)
77 Lisp_Face *face = XFACE (obj);
79 mark_object (face->name);
80 mark_object (face->doc_string);
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);
94 mark_object (face->charsets_warned_about);
100 print_face (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
102 Lisp_Face *face = XFACE (obj);
106 write_c_string ("#s(face name ", printcharfun);
107 print_internal (face->name, printcharfun, 1);
108 write_c_string (")", printcharfun);
112 write_c_string ("#<face ", printcharfun);
113 print_internal (face->name, printcharfun, 1);
114 if (!NILP (face->doc_string))
116 write_c_string (" ", printcharfun);
117 print_internal (face->doc_string, printcharfun, 1);
119 write_c_string (">", printcharfun);
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
127 This isn't concerned with "unspecified" attributes, that's what
128 #'face-differs-from-default-p is for. */
130 face_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
132 Lisp_Face *f1 = XFACE (obj1);
133 Lisp_Face *f2 = XFACE (obj2);
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) &&
150 ! plists_differ (f1->plist, f2->plist, 0, 0, depth + 1));
154 face_hash (Lisp_Object obj, int depth)
156 Lisp_Face *f = XFACE (obj);
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));
168 face_getprop (Lisp_Object obj, Lisp_Object prop)
170 Lisp_Face *f = XFACE (obj);
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));
189 face_putprop (Lisp_Object obj, Lisp_Object prop, Lisp_Object value)
191 Lisp_Face *f = XFACE (obj);
193 if (EQ (prop, Qforeground) ||
194 EQ (prop, Qbackground) ||
196 EQ (prop, Qdisplay_table) ||
197 EQ (prop, Qbackground_pixmap) ||
198 EQ (prop, Qunderline) ||
199 EQ (prop, Qstrikethru) ||
200 EQ (prop, Qhighlight) ||
202 EQ (prop, Qblinking) ||
206 if (EQ (prop, Qdoc_string))
209 CHECK_STRING (value);
210 f->doc_string = value;
214 external_plist_put (&f->plist, prop, value, 0, ERROR_ME);
219 face_remprop (Lisp_Object obj, Lisp_Object prop)
221 Lisp_Face *f = XFACE (obj);
223 if (EQ (prop, Qforeground) ||
224 EQ (prop, Qbackground) ||
226 EQ (prop, Qdisplay_table) ||
227 EQ (prop, Qbackground_pixmap) ||
228 EQ (prop, Qunderline) ||
229 EQ (prop, Qstrikethru) ||
230 EQ (prop, Qhighlight) ||
232 EQ (prop, Qblinking) ||
236 if (EQ (prop, Qdoc_string))
238 f->doc_string = Qnil;
242 return external_remprop (&f->plist, prop, 0, ERROR_ME);
246 face_plist (Lisp_Object obj)
248 Lisp_Face *face = XFACE (obj);
249 Lisp_Object result = face->plist;
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);
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) },
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);
291 /************************************************************************/
292 /* face read syntax */
293 /************************************************************************/
296 face_name_validate (Lisp_Object keyword, Lisp_Object value,
299 if (ERRB_EQ (errb, ERROR_ME))
301 CHECK_SYMBOL (value);
305 return SYMBOLP (value);
309 face_validate (Lisp_Object data, Error_behavior errb)
312 Lisp_Object valw = Qnil;
314 data = Fcdr (data); /* skip over Qface */
317 Lisp_Object keyw = Fcar (data);
322 if (EQ (keyw, Qname))
330 maybe_error (Qface, errb, "No face name given");
334 if (NILP (Ffind_face (valw)))
336 maybe_signal_simple_error ("No such face", valw, Qface, errb);
344 face_instantiate (Lisp_Object data)
346 return Fget_face (Fcar (Fcdr (data)));
350 /****************************************************************************
351 * utility functions *
352 ****************************************************************************/
355 reset_face (Lisp_Face *f)
358 f->doc_string = Qnil;
360 f->foreground = Qnil;
361 f->background = Qnil;
363 f->display_table = Qnil;
364 f->background_pixmap = Qnil;
366 f->strikethru = Qnil;
372 f->charsets_warned_about = Qnil;
378 Lisp_Face *result = alloc_lcrecord_type (Lisp_Face, &lrecord_face);
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
390 Lisp_Object *face_list;
394 add_face_to_list_mapper (Lisp_Object key, Lisp_Object value,
395 void *face_list_closure)
397 /* This function can GC */
398 struct face_list_closure *fcl =
399 (struct face_list_closure *) face_list_closure;
401 *(fcl->face_list) = Fcons (XFACE (value)->name, (*fcl->face_list));
406 faces_list_internal (Lisp_Object list)
408 Lisp_Object face_list = Qnil;
410 struct face_list_closure face_list_closure;
413 face_list_closure.face_list = &face_list;
414 elisp_maphash (add_face_to_list_mapper, list, &face_list_closure);
421 permanent_faces_list (void)
423 return faces_list_internal (Vpermanent_faces_cache);
427 temporary_faces_list (void)
429 return faces_list_internal (Vtemporary_faces_cache);
434 mark_face_as_clean_mapper (Lisp_Object key, Lisp_Object value,
437 /* This function can GC */
438 int *flag = (int *) flag_closure;
439 XFACE (value)->dirty = *flag;
444 mark_all_faces_internal (int flag)
446 elisp_maphash (mark_face_as_clean_mapper, Vpermanent_faces_cache, &flag);
447 elisp_maphash (mark_face_as_clean_mapper, Vtemporary_faces_cache, &flag);
451 mark_all_faces_as_clean (void)
453 mark_all_faces_internal (0);
456 /* Currently unused (see the comment in face_property_was_changed()). */
458 /* #### OBSOLETE ME, PLEASE. Maybe. Maybe this is just as good as
459 any other solution. */
460 struct face_inheritance_closure
463 Lisp_Object property;
467 update_inheritance_mapper_internal (Lisp_Object cur_face,
468 Lisp_Object inh_face,
469 Lisp_Object property)
471 /* #### fix this function */
472 Lisp_Object elt = Qnil;
477 for (elt = FACE_PROPERTY_SPEC_LIST (cur_face, property, Qall);
481 Lisp_Object values = XCDR (XCAR (elt));
483 for (; !NILP (values); values = XCDR (values))
485 Lisp_Object value = XCDR (XCAR (values));
486 if (VECTORP (value) && XVECTOR_LENGTH (value))
488 if (EQ (Ffind_face (XVECTOR_DATA (value)[0]), inh_face))
489 Fset_specifier_dirty_flag
490 (FACE_PROPERTY_SPECIFIER (inh_face, property));
499 update_face_inheritance_mapper (const void *hash_key, void *hash_contents,
500 void *face_inheritance_closure)
502 Lisp_Object key, contents;
503 struct face_inheritance_closure *fcl =
504 (struct face_inheritance_closure *) face_inheritance_closure;
506 CVOID_TO_LISP (key, hash_key);
507 VOID_TO_LISP (contents, hash_contents);
509 if (EQ (fcl->property, Qfont))
511 update_inheritance_mapper_internal (contents, fcl->face, Qfont);
513 else if (EQ (fcl->property, Qforeground) ||
514 EQ (fcl->property, Qbackground))
516 update_inheritance_mapper_internal (contents, fcl->face, Qforeground);
517 update_inheritance_mapper_internal (contents, fcl->face, Qbackground);
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))
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);
537 update_faces_inheritance (Lisp_Object face, Lisp_Object property)
539 struct face_inheritance_closure face_inheritance_closure;
540 struct gcpro gcpro1, gcpro2;
542 GCPRO2 (face, property);
543 face_inheritance_closure.face = face;
544 face_inheritance_closure.property = property;
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);
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,
562 specifier_instance_no_quit (Fget (face, property, Qnil), charset,
563 domain, errb, no_fallback, depth);
565 if (UNBOUNDP (retval) && !no_fallback)
567 if (EQ (property, Qfont))
569 if (NILP (memq_no_quit (charset,
570 XFACE (face)->charsets_warned_about)))
573 if (! UNBOUNDP (charset))
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)))));
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);
590 retval = Vthe_null_font_instance;
598 DEFUN ("facep", Ffacep, 1, 1, 0, /*
599 Return t if OBJECT is a face.
603 return FACEP (object) ? Qt : Qnil;
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.
616 if (FACEP (face_or_name))
618 CHECK_SYMBOL (face_or_name);
620 /* Check if the name represents a permanent face. */
621 retval = Fgethash (face_or_name, Vpermanent_faces_cache, Qnil);
625 /* Check if the name represents a temporary face. */
626 return Fgethash (face_or_name, Vtemporary_faces_cache, Qnil);
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.
636 Lisp_Object face = Ffind_face (name);
639 signal_simple_error ("No such face", name);
643 DEFUN ("face-name", Fface_name, 1, 1, 0, /*
644 Return the name of the given face.
648 return XFACE (Fget_face (face))->name;
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!
657 return Vbuilt_in_face_specifiers;
660 /* These values are retrieved so often that we make a special
665 default_face_font_info (Lisp_Object domain, int *ascent, int *descent,
666 int *height, int *width, int *proportional_p)
668 Lisp_Object font_instance;
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))
690 struct face_cachel *cachel;
691 struct window *w = XWINDOW (domain);
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);
702 font_instance = FACE_FONT (Vdefault_face, domain, Vcharset_ascii);
706 *height = XFONT_INSTANCE (font_instance)->height;
708 *width = XFONT_INSTANCE (font_instance)->width;
710 *ascent = XFONT_INSTANCE (font_instance)->ascent;
712 *descent = XFONT_INSTANCE (font_instance)->descent;
714 *proportional_p = XFONT_INSTANCE (font_instance)->proportional_p;
718 default_face_height_and_width (Lisp_Object domain,
719 int *height, int *width)
721 default_face_font_info (domain, 0, 0, height, width, 0);
725 default_face_height_and_width_1 (Lisp_Object domain,
726 int *height, int *width)
728 if (window_system_pixelated_geometry (domain))
736 default_face_height_and_width (domain, height, width);
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.
747 Lisp_Object face_list = Qnil;
749 /* Added the permanent faces, if requested. */
750 if (NILP (temporary) || !EQ (Qt, temporary))
751 face_list = permanent_faces_list ();
753 if (!NILP (temporary))
757 face_list = nconc2 (face_list, temporary_faces_list ());
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.
770 (name, doc_string, temporary))
772 /* This function can GC if initialized is non-zero */
777 if (!NILP (doc_string))
778 CHECK_STRING (doc_string);
780 face = Ffind_face (name);
784 f = allocate_face ();
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))
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,
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));
841 /* Add the face to the appropriate list. */
842 if (NILP (temporary))
843 Fputhash (name, face, Vpermanent_faces_cache);
845 Fputhash (name, face, Vtemporary_faces_cache);
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
851 if (initialized && !noninteractive)
853 struct gcpro gcpro1, gcpro2;
856 call1 (Qinit_face_from_resources, name);
864 /*****************************************************************************
866 ****************************************************************************/
869 init_global_faces (struct device *d)
871 /* When making the initial terminal device, there is no Lisp code
872 loaded, so we can't do this. */
873 if (initialized && !noninteractive)
875 call_critical_lisp_code (d, Qinit_global_faces, Qnil);
880 init_device_faces (struct device *d)
882 /* This function can call lisp */
884 /* When making the initial terminal device, there is no Lisp code
885 loaded, so we can't do this. */
889 XSETDEVICE (tdevice, d);
890 call_critical_lisp_code (d, Qinit_device_faces, tdevice);
895 init_frame_faces (struct frame *frm)
897 /* When making the initial terminal device, there is no Lisp code
898 loaded, so we can't do this. */
902 XSETFRAME (tframe, frm);
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);
920 /****************************************************************************
921 * face cache element functions *
922 ****************************************************************************/
926 #### Here is a description of how the face cache elements ought
927 to be redone. It is *NOT* how they work currently:
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.
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.
945 Here's an approach that should keep things clean and unconfused:
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
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
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
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.
998 /* mark for GC a dynarr of face cachels. */
1001 mark_face_cachels (face_cachel_dynarr *elements)
1008 for (elt = 0; elt < Dynarr_length (elements); elt++)
1010 struct face_cachel *cachel = Dynarr_atp (elements, elt);
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]);
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);
1027 /* ensure that the given cachel contains an updated font value for
1028 the given charset. Return the updated font value. */
1031 ensure_face_cachel_contains_charset (struct face_cachel *cachel,
1032 Lisp_Object domain, Lisp_Object charset)
1034 Lisp_Object new_val;
1035 Lisp_Object face = cachel->face;
1037 int offs = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
1039 if (!UNBOUNDP (cachel->font[offs])
1040 && cachel->font_updated[offs])
1041 return cachel->font[offs];
1043 if (UNBOUNDP (face))
1045 /* a merged face. */
1047 struct window *w = XWINDOW (domain);
1050 cachel->font_specified[offs] = 0;
1051 for (i = 0; i < cachel->nfaces; i++)
1053 struct face_cachel *oth;
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);
1060 if (oth->font_specified[offs])
1062 new_val = oth->font[offs];
1063 cachel->font_specified[offs] = 1;
1068 if (!cachel->font_specified[offs])
1069 /* need to do the default face. */
1071 struct face_cachel *oth =
1072 Dynarr_atp (w->face_cachels, DEFAULT_INDEX);
1073 ensure_face_cachel_contains_charset (oth, domain, charset);
1075 new_val = oth->font[offs];
1078 if (!UNBOUNDP (cachel->font[offs]) && !EQ (cachel->font[offs], new_val))
1080 cachel->font_updated[offs] = 1;
1081 cachel->font[offs] = new_val;
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))
1091 new_val = face_property_matching_instance (face, Qfont,
1095 ERROR_ME_NOT, 0, Qzero);
1097 if (!UNBOUNDP (cachel->font[offs]) && !EQ (new_val, cachel->font[offs]))
1099 cachel->font_updated[offs] = 1;
1100 cachel->font[offs] = new_val;
1101 cachel->font_specified[offs] = (bound || EQ (face, Vdefault_face));
1105 /* Ensure that the given cachel contains updated fonts for all
1106 the charsets specified. */
1109 ensure_face_cachel_complete (struct face_cachel *cachel,
1110 Lisp_Object domain, Charset_ID *charsets)
1114 for (i = 0; i < NUM_LEADING_BYTES; i++)
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);
1124 face_cachel_charset_font_metric_info (struct face_cachel *cachel,
1125 Charset_ID *charsets,
1126 struct font_metric_info *fm)
1131 fm->height = fm->ascent = 1;
1133 fm->proportional_p = 0;
1135 for (i = 0; i < NUM_LEADING_BYTES; i++)
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);
1143 assert (CHARSETP (charset));
1144 assert (FONT_INSTANCEP (font_instance));
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;
1157 #define FROB(field) \
1159 Lisp_Object new_val = \
1160 FACE_PROPERTY_INSTANCE (face, Q##field, domain, 1, Qzero); \
1162 if (UNBOUNDP (new_val)) \
1165 new_val = FACE_PROPERTY_INSTANCE (face, Q##field, domain, 0, Qzero); \
1167 if (!EQ (new_val, cachel->field)) \
1169 cachel->field = new_val; \
1170 cachel->dirty = 1; \
1172 cachel->field##_specified = (bound || default_face); \
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
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.
1186 #define MAYBE_UNFROB_BACKGROUND_PIXMAP \
1189 if (! default_face \
1190 && cachel->background_specified \
1191 && ! cachel->background_pixmap_specified) \
1193 cachel->background_pixmap = Qunbound; \
1194 cachel->background_pixmap_specified = 1; \
1199 /* Add a cachel for the given face to the given window's cache. */
1202 add_face_cachel (struct window *w, Lisp_Object face)
1204 int must_finish_frobbing = ! WINDOW_FACE_CACHEL (w, DEFAULT_INDEX);
1205 struct face_cachel new_cachel;
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);
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)
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);
1221 FROB (background_pixmap);
1222 MAYBE_UNFROB_BACKGROUND_PIXMAP;
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.
1232 update_face_cachel_data (struct face_cachel *cachel,
1236 if (XFACE (face)->dirty || UNBOUNDP (cachel->face))
1238 int default_face = EQ (face, Vdefault_face);
1239 cachel->face = face;
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. */
1247 FROB (display_table);
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:
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
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.
1278 * See comment in `default_face_font_info' in face.c. Who wrote it ?
1279 Maybe we have the begining of an answer here ?
1282 [1] See comment at the top of `allocate_window' in window.c.
1286 if (! WINDOWP (domain)
1287 || WINDOW_FACE_CACHEL (DOMAIN_XWINDOW (domain), DEFAULT_INDEX))
1289 FROB (background_pixmap);
1290 MAYBE_UNFROB_BACKGROUND_PIXMAP;
1293 #undef MAYBE_UNFROB_BACKGROUND_PIXMAP
1295 ensure_face_cachel_contains_charset (cachel, domain, Vcharset_ascii);
1297 #define FROB(field) \
1299 Lisp_Object new_val = \
1300 FACE_PROPERTY_INSTANCE (face, Q##field, domain, 1, Qzero); \
1302 unsigned int new_val_int; \
1303 if (UNBOUNDP (new_val)) \
1306 new_val = FACE_PROPERTY_INSTANCE (face, Q##field, domain, 0, Qzero); \
1308 new_val_int = EQ (new_val, Qt); \
1309 if (cachel->field != new_val_int) \
1311 cachel->field = new_val_int; \
1312 cachel->dirty = 1; \
1314 cachel->field##_specified = bound; \
1326 cachel->updated = 1;
1329 /* Merge the cachel identified by FINDEX in window W into the given
1333 merge_face_cachel_data (struct window *w, face_index findex,
1334 struct face_cachel *cachel)
1336 #define FINDEX_FIELD(field) \
1337 Dynarr_atp (w->face_cachels, findex)->field
1339 #define FROB(field) \
1341 if (!cachel->field##_specified && FINDEX_FIELD (field##_specified)) \
1343 cachel->field = FINDEX_FIELD (field); \
1344 cachel->field##_specified = 1; \
1345 cachel->dirty = 1; \
1351 FROB (display_table);
1352 FROB (background_pixmap);
1359 /* And do ASCII, of course. */
1361 int offs = LEADING_BYTE_ASCII - MIN_LEADING_BYTE;
1363 if (!cachel->font_specified[offs] && FINDEX_FIELD (font_specified[offs]))
1365 cachel->font[offs] = FINDEX_FIELD (font[offs]);
1366 cachel->font_specified[offs] = 1;
1374 cachel->updated = 1;
1377 /* Initialize a cachel. */
1380 reset_face_cachel (struct face_cachel *cachel)
1383 cachel->face = Qunbound;
1385 cachel->merged_faces = 0;
1386 cachel->foreground = Qunbound;
1387 cachel->background = Qunbound;
1391 for (i = 0; i < NUM_LEADING_BYTES; i++)
1392 cachel->font[i] = Qunbound;
1394 cachel->display_table = Qunbound;
1395 cachel->background_pixmap = Qunbound;
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
1403 get_builtin_face_cache_index (struct window *w, Lisp_Object face)
1410 for (elt = 0; elt < Dynarr_length (w->face_cachels); elt++)
1412 struct face_cachel *cachel = WINDOW_FACE_CACHEL (w, elt);
1414 if (EQ (cachel->face, face))
1417 XSETWINDOW (window, w);
1418 if (!cachel->updated)
1419 update_face_cachel_data (cachel, window, face);
1424 /* If we didn't find the face, add it and then return its index. */
1425 add_face_cachel (w, face);
1430 reset_face_cachels (struct window *w)
1432 /* #### Not initialized in batch mode for the stream device. */
1433 if (w->face_cachels)
1437 for (i = 0; i < Dynarr_length (w->face_cachels); i++)
1439 struct face_cachel *cachel = Dynarr_atp (w->face_cachels, i);
1440 if (cachel->merged_faces)
1441 Dynarr_free (cachel->merged_faces);
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;
1451 mark_face_cachels_as_clean (struct window *w)
1455 for (elt = 0; elt < Dynarr_length (w->face_cachels); elt++)
1456 Dynarr_atp (w->face_cachels, elt)->dirty = 0;
1460 mark_face_cachels_as_not_updated (struct window *w)
1464 for (elt = 0; elt < Dynarr_length (w->face_cachels); elt++)
1466 struct face_cachel *cachel = Dynarr_atp (w->face_cachels, elt);
1469 cachel->updated = 0;
1470 for (i = 0; i < NUM_LEADING_BYTES; i++)
1471 cachel->font_updated[i] = 0;
1475 #ifdef MEMORY_USAGE_STATS
1478 compute_face_cachel_usage (face_cachel_dynarr *face_cachels,
1479 struct overhead_stats *ovstats)
1487 total += Dynarr_memory_usage (face_cachels, ovstats);
1488 for (i = 0; i < Dynarr_length (face_cachels); i++)
1490 int_dynarr *merged = Dynarr_at (face_cachels, i).merged_faces;
1492 total += Dynarr_memory_usage (merged, ovstats);
1499 #endif /* MEMORY_USAGE_STATS */
1502 /*****************************************************************************
1503 * merged face functions *
1504 *****************************************************************************/
1506 /* Compare two merged face cachels to determine whether we have to add
1507 a new entry to the face cache.
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. */
1516 compare_merged_face_cachels (struct face_cachel *cachel1,
1517 struct face_cachel *cachel2)
1521 if (!EQ (cachel1->face, cachel2->face)
1522 || cachel1->nfaces != cachel2->nfaces)
1525 for (i = 0; i < cachel1->nfaces; i++)
1526 if (FACE_CACHEL_FINDEX_UNSAFE (cachel1, i)
1527 != FACE_CACHEL_FINDEX_UNSAFE (cachel2, i))
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
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. */
1544 get_merged_face_cache_index (struct window *w,
1545 struct face_cachel *merged_cachel)
1548 int cache_size = Dynarr_length (w->face_cachels);
1550 for (elt = 0; elt < cache_size; elt++)
1552 struct face_cachel *cachel =
1553 Dynarr_atp (w->face_cachels, elt);
1555 if (compare_merged_face_cachels (cachel, merged_cachel))
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);
1567 get_extent_fragment_face_cache_index (struct window *w,
1568 struct extent_fragment *ef)
1570 struct face_cachel cachel;
1571 int len = Dynarr_length (ef->extents);
1572 face_index findex = 0;
1574 XSETWINDOW (window, w);
1576 /* Optimize the default case. */
1578 return DEFAULT_INDEX;
1583 /* Merge the faces of the extents together in order. */
1585 reset_face_cachel (&cachel);
1587 for (i = len - 1; i >= 0; i--)
1589 EXTENT current = Dynarr_at (ef->extents, i);
1591 Lisp_Object face = extent_face (current);
1595 findex = get_builtin_face_cache_index (w, face);
1597 merge_face_cachel_data (w, findex, &cachel);
1599 /* remember, we're called from within redisplay
1600 so we can't error. */
1601 else while (CONSP (face))
1603 Lisp_Object one_face = XCAR (face);
1604 if (FACEP (one_face))
1606 findex = get_builtin_face_cache_index (w, one_face);
1607 merge_face_cachel_data (w, findex, &cachel);
1609 /* code duplication here but there's no clean
1611 if (cachel.nfaces >= NUM_STATIC_CACHEL_FACES)
1613 if (!cachel.merged_faces)
1614 cachel.merged_faces = Dynarr_new (int);
1615 Dynarr_add (cachel.merged_faces, findex);
1618 cachel.merged_faces_static[cachel.nfaces] = findex;
1626 if (cachel.nfaces >= NUM_STATIC_CACHEL_FACES)
1628 if (!cachel.merged_faces)
1629 cachel.merged_faces = Dynarr_new (int);
1630 Dynarr_add (cachel.merged_faces, findex);
1633 cachel.merged_faces_static[cachel.nfaces] = findex;
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);
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)
1648 Dynarr_free (cachel.merged_faces);
1649 cachel.merged_faces = 0;
1656 /*****************************************************************************
1658 ****************************************************************************/
1661 update_EmacsFrame (Lisp_Object frame, Lisp_Object name)
1663 struct frame *frm = XFRAME (frame);
1665 if (EQ (name, Qfont))
1666 MARK_FRAME_SIZE_SLIPPED (frm);
1668 MAYBE_FRAMEMETH (frm, update_frame_external_traits, (frm, name));
1672 update_EmacsFrames (Lisp_Object locale, Lisp_Object name)
1674 if (FRAMEP (locale))
1676 update_EmacsFrame (locale, name);
1678 else if (DEVICEP (locale))
1680 Lisp_Object frmcons;
1682 DEVICE_FRAME_LOOP (frmcons, XDEVICE (locale))
1683 update_EmacsFrame (XCAR (frmcons), name);
1685 else if (EQ (locale, Qglobal) || EQ (locale, Qfallback))
1687 Lisp_Object frmcons, devcons, concons;
1689 FRAME_LOOP_NO_BREAK (frmcons, devcons, concons)
1690 update_EmacsFrame (XCAR (frmcons), name);
1695 update_frame_face_values (struct frame *f)
1700 update_EmacsFrame (frm, Qforeground);
1701 update_EmacsFrame (frm, Qbackground);
1702 update_EmacsFrame (frm, Qfont);
1706 face_property_was_changed (Lisp_Object face, Lisp_Object property,
1709 int default_face = EQ (face, Vdefault_face);
1711 /* If the locale could affect the frame value, then call
1712 update_EmacsFrames just in case. */
1714 (EQ (property, Qforeground) ||
1715 EQ (property, Qbackground) ||
1716 EQ (property, Qfont)))
1717 update_EmacsFrames (locale, property);
1719 if (WINDOWP (locale))
1721 MARK_FRAME_FACES_CHANGED (XFRAME (XWINDOW (locale)->frame));
1723 else if (FRAMEP (locale))
1725 MARK_FRAME_FACES_CHANGED (XFRAME (locale));
1727 else if (DEVICEP (locale))
1729 MARK_DEVICE_FRAMES_FACES_CHANGED (XDEVICE (locale));
1733 Lisp_Object devcons, concons;
1734 DEVICE_LOOP_NO_BREAK (devcons, concons)
1735 MARK_DEVICE_FRAMES_FACES_CHANGED (XDEVICE (XCAR (devcons)));
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!
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
1755 /* update_faces_inheritance (face, property);*/
1756 XFACE (face)->dirty = 1;
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'.
1764 (old_face, new_name, locale, tag_set, exact_p, how_to_add))
1766 Lisp_Face *fold, *fnew;
1767 Lisp_Object new_face = Qnil;
1768 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
1770 old_face = Fget_face (old_face);
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);
1782 new_face = Ffind_face (new_name);
1783 if (NILP (new_face))
1787 CHECK_SYMBOL (new_name);
1789 /* Create the new face with the same status as the old face. */
1790 temp = (NILP (Fgethash (old_face, Vtemporary_faces_cache, Qnil))
1794 new_face = Fmake_face (new_name, Qnil, temp);
1797 fold = XFACE (old_face);
1798 fnew = XFACE (new_face);
1800 #define COPY_PROPERTY(property) \
1801 Fcopy_specifier (fold->property, fnew->property, \
1802 locale, tag_set, exact_p, how_to_add);
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);
1826 syms_of_faces (void)
1828 INIT_LRECORD_IMPLEMENTATION (face);
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");
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);
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");
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");
1864 structure_type_create_faces (void)
1866 struct structure_type *st;
1868 st = define_structure_type (Qface, face_validate, face_instantiate);
1870 define_structure_type_keyword (st, Qname, face_name_validate);
1874 vars_of_faces (void)
1876 staticpro (&Vpermanent_faces_cache);
1877 Vpermanent_faces_cache = Qnil;
1878 staticpro (&Vtemporary_faces_cache);
1879 Vtemporary_faces_cache = Qnil;
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;
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;
1904 Lisp_Object syms[20];
1907 syms[n++] = Qforeground;
1908 syms[n++] = Qbackground;
1910 syms[n++] = Qdisplay_table;
1911 syms[n++] = Qbackground_pixmap;
1912 syms[n++] = Qunderline;
1913 syms[n++] = Qstrikethru;
1914 syms[n++] = Qhighlight;
1916 syms[n++] = Qblinking;
1917 syms[n++] = Qreverse;
1919 Vbuilt_in_face_specifiers = Flist (n, syms);
1920 staticpro (&Vbuilt_in_face_specifiers);
1925 complex_vars_of_faces (void)
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);
1932 /* Create the default face now so we know what it is immediately. */
1934 Vdefault_face = Qnil; /* so that Fmake_face() doesn't set up a bogus
1936 Vdefault_face = Fmake_face (Qdefault, build_string ("default face"),
1939 /* Provide some last-resort fallbacks to avoid utter fuckage if
1940 someone provides invalid values for the global specifications. */
1943 Lisp_Object fg_fb = Qnil, bg_fb = Qnil;
1946 fg_fb = acons (list1 (Qgtk), build_string ("black"), fg_fb);
1947 bg_fb = acons (list1 (Qgtk), build_string ("white"), bg_fb);
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);
1954 fg_fb = acons (list1 (Qtty), Fvector (0, 0), fg_fb);
1955 bg_fb = acons (list1 (Qtty), Fvector (0, 0), bg_fb);
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);
1963 set_specifier_fallback (Fget (Vdefault_face, Qforeground, Qnil), fg_fb);
1964 set_specifier_fallback (Fget (Vdefault_face, Qbackground, Qnil), bg_fb);
1967 /* #### We may want to have different fallback values if NeXTstep
1968 support is compiled in. */
1970 Lisp_Object inst_list = Qnil;
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
1977 ** WMP March 9, 2001
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.)
1984 const char *fonts[] =
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-*-*-*-*-*-*",
2002 const char **fontptr;
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)),
2008 #endif /* HAVE_X_WINDOWS */
2011 for (fontptr = fonts + countof(fonts) - 1; fontptr >= fonts; fontptr--)
2012 inst_list = Fcons (Fcons (list1 (Qgtk), build_string (*fontptr)),
2014 #endif /* HAVE_GTK */
2015 #endif /* HAVE_X_WINDOWS || HAVE_GTK */
2019 inst_list = Fcons (Fcons (list1 (Qtty), build_string ("normal")),
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);
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);
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)));
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"),
2058 /* Provide some last-resort fallbacks for gui-element face which
2059 mustn't default to default. */
2061 Lisp_Object fg_fb = Qnil, bg_fb = Qnil;
2064 /* We need to put something in there, or error checking gets
2065 #%!@#ed up before the styles are set, which override the
2067 fg_fb = acons (list1 (Qgtk), build_string ("black"), fg_fb);
2068 bg_fb = acons (list1 (Qgtk), build_string ("Gray80"), bg_fb);
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);
2075 fg_fb = acons (list1 (Qtty), Fvector (0, 0), fg_fb);
2076 bg_fb = acons (list1 (Qtty), Fvector (0, 0), bg_fb);
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);
2084 set_specifier_fallback (Fget (Vgui_element_face, Qforeground, Qnil), fg_fb);
2085 set_specifier_fallback (Fget (Vgui_element_face, Qbackground, Qnil), bg_fb);
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. */
2092 /* modeline is gui element. */
2093 Vmodeline_face = Fmake_face (Qmodeline, build_string ("modeline face"),
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,
2104 /* toolbar is another gui element */
2105 Vtoolbar_face = Fmake_face (Qtoolbar,
2106 build_string ("toolbar face"),
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,
2116 /* vertical divider is another gui element */
2117 Vvertical_divider_face = Fmake_face (Qvertical_divider,
2118 build_string ("vertical divider face"),
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,
2127 Fget (Vgui_element_face, Qbackground_pixmap,
2130 /* widget is another gui element */
2131 Vwidget_face = Fmake_face (Qwidget,
2132 build_string ("widget face"),
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. */
2142 Vleft_margin_face = Fmake_face (Qleft_margin,
2143 build_string ("left margin face"),
2145 Vright_margin_face = Fmake_face (Qright_margin,
2146 build_string ("right margin face"),
2148 Vtext_cursor_face = Fmake_face (Qtext_cursor,
2149 build_string ("face for text cursor"),
2152 Fmake_face (Qpointer,
2154 ("face for foreground/background colors of mouse pointer"),