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 SXEmacs
9 SXEmacs is free software: you can redistribute it and/or modify
10 it under the terms of the GNU General Public License as published by
11 the Free Software Foundation, either version 3 of the License, or
12 (at your option) any later version.
14 SXEmacs is distributed in the hope that it will be useful,
15 but WITHOUT ANY WARRANTY; without even the implied warranty of
16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 GNU General Public License for more details.
19 You should have received a copy of the GNU General Public License
20 along with this program. If not, see <http://www.gnu.org/licenses/>. */
23 /* Synched up with: Not in FSF. */
25 /* Written by Chuck Thompson and Ben Wing,
26 based loosely on old face code by Jamie Zawinski. */
39 #include "specifier.h"
43 Lisp_Object Qforeground, Qbackground, Qdisplay_table;
44 Lisp_Object Qbackground_pixmap, Qunderline, Qdim;
45 Lisp_Object Qblinking, Qstrikethru;
47 Lisp_Object Qinit_face_from_resources;
48 Lisp_Object Qinit_frame_faces;
49 Lisp_Object Qinit_device_faces;
50 Lisp_Object Qinit_global_faces;
52 /* These faces are used directly internally. We use these variables
53 to be able to reference them directly and save the overhead of
54 calling Ffind_face. */
55 Lisp_Object Vdefault_face, Vmodeline_face, Vgui_element_face;
56 Lisp_Object Vleft_margin_face, Vright_margin_face, Vtext_cursor_face;
57 Lisp_Object Vpointer_face, Vvertical_divider_face, Vtoolbar_face, Vwidget_face;
59 /* Qdefault, Qhighlight, Qleft_margin, Qright_margin defined in general.c */
60 Lisp_Object Qmodeline, Qgui_element, Qtext_cursor, Qvertical_divider;
62 /* In the old implementation Vface_list was a list of the face names,
63 not the faces themselves. We now distinguish between permanent and
64 temporary faces. Permanent faces are kept in a regular hash table,
65 temporary faces in a weak hash table. */
66 Lisp_Object Vpermanent_faces_cache;
67 Lisp_Object Vtemporary_faces_cache;
69 Lisp_Object Vbuilt_in_face_specifiers;
71 static Lisp_Object mark_face(Lisp_Object obj)
73 Lisp_Face *face = XFACE(obj);
75 mark_object(face->name);
76 mark_object(face->doc_string);
78 mark_object(face->foreground);
79 mark_object(face->background);
80 mark_object(face->font);
81 mark_object(face->display_table);
82 mark_object(face->background_pixmap);
83 mark_object(face->underline);
84 mark_object(face->strikethru);
85 mark_object(face->highlight);
86 mark_object(face->dim);
87 mark_object(face->blinking);
88 mark_object(face->reverse);
90 mark_object(face->charsets_warned_about);
96 print_face(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
98 Lisp_Face *face = XFACE(obj);
100 if (print_readably) {
101 write_c_string("#s(face name ", printcharfun);
102 print_internal(face->name, printcharfun, 1);
103 write_c_string(")", printcharfun);
105 write_c_string("#<face ", printcharfun);
106 print_internal(face->name, printcharfun, 1);
107 if (!NILP(face->doc_string)) {
108 write_c_string(" ", printcharfun);
109 print_internal(face->doc_string, printcharfun, 1);
111 write_c_string(">", printcharfun);
115 /* Faces are equal if all of their display attributes are equal. We
116 don't compare names or doc-strings, because that would make equal
119 This isn't concerned with "unspecified" attributes, that's what
120 #'face-differs-from-default-p is for. */
121 static int face_equal(Lisp_Object obj1, Lisp_Object obj2, int depth)
123 Lisp_Face *f1 = XFACE(obj1);
124 Lisp_Face *f2 = XFACE(obj2);
129 (internal_equal(f1->foreground, f2->foreground, depth) &&
130 internal_equal(f1->background, f2->background, depth) &&
131 internal_equal(f1->font, f2->font, depth) &&
132 internal_equal(f1->display_table, f2->display_table, depth) &&
133 internal_equal(f1->background_pixmap, f2->background_pixmap, depth)
134 && internal_equal(f1->underline, f2->underline, depth)
135 && internal_equal(f1->strikethru, f2->strikethru, depth)
136 && internal_equal(f1->highlight, f2->highlight, depth)
137 && internal_equal(f1->dim, f2->dim, depth)
138 && internal_equal(f1->blinking, f2->blinking, depth)
139 && internal_equal(f1->reverse, f2->reverse, depth)
140 && !plists_differ(f1->plist, f2->plist, 0, 0, depth + 1));
143 static unsigned long face_hash(Lisp_Object obj, int depth)
145 Lisp_Face *f = XFACE(obj);
149 /* No need to hash all of the elements; that would take too long.
150 Just hash the most common ones. */
151 return HASH3(internal_hash(f->foreground, depth),
152 internal_hash(f->background, depth),
153 internal_hash(f->font, depth));
156 static Lisp_Object face_getprop(Lisp_Object obj, Lisp_Object prop)
158 Lisp_Face *f = XFACE(obj);
161 (EQ(prop, Qforeground) ? f->foreground :
162 EQ(prop, Qbackground) ? f->background :
163 EQ(prop, Qfont) ? f->font :
164 EQ(prop, Qdisplay_table) ? f->display_table :
165 EQ(prop, Qbackground_pixmap) ? f->background_pixmap :
166 EQ(prop, Qunderline) ? f->underline :
167 EQ(prop, Qstrikethru) ? f->strikethru :
168 EQ(prop, Qhighlight) ? f->highlight :
169 EQ(prop, Qdim) ? f->dim :
170 EQ(prop, Qblinking) ? f->blinking :
171 EQ(prop, Qreverse) ? f->reverse :
172 EQ(prop, Qdoc_string) ? f->doc_string :
173 external_plist_get(&f->plist, prop, 0, ERROR_ME));
176 static int face_putprop(Lisp_Object obj, Lisp_Object prop, Lisp_Object value)
178 Lisp_Face *f = XFACE(obj);
180 if (EQ(prop, Qforeground) ||
181 EQ(prop, Qbackground) ||
183 EQ(prop, Qdisplay_table) ||
184 EQ(prop, Qbackground_pixmap) ||
185 EQ(prop, Qunderline) ||
186 EQ(prop, Qstrikethru) ||
187 EQ(prop, Qhighlight) ||
188 EQ(prop, Qdim) || EQ(prop, Qblinking) || EQ(prop, Qreverse))
191 if (EQ(prop, Qdoc_string)) {
194 f->doc_string = value;
198 external_plist_put(&f->plist, prop, value, 0, ERROR_ME);
202 static int face_remprop(Lisp_Object obj, Lisp_Object prop)
204 Lisp_Face *f = XFACE(obj);
206 if (EQ(prop, Qforeground) ||
207 EQ(prop, Qbackground) ||
209 EQ(prop, Qdisplay_table) ||
210 EQ(prop, Qbackground_pixmap) ||
211 EQ(prop, Qunderline) ||
212 EQ(prop, Qstrikethru) ||
213 EQ(prop, Qhighlight) ||
214 EQ(prop, Qdim) || EQ(prop, Qblinking) || EQ(prop, Qreverse))
217 if (EQ(prop, Qdoc_string)) {
218 f->doc_string = Qnil;
222 return external_remprop(&f->plist, prop, 0, ERROR_ME);
225 static Lisp_Object face_plist(Lisp_Object obj)
227 Lisp_Face *face = XFACE(obj);
228 Lisp_Object result = face->plist;
230 result = cons3(Qreverse, face->reverse, result);
231 result = cons3(Qblinking, face->blinking, result);
232 result = cons3(Qdim, face->dim, result);
233 result = cons3(Qhighlight, face->highlight, result);
234 result = cons3(Qstrikethru, face->strikethru, result);
235 result = cons3(Qunderline, face->underline, result);
236 result = cons3(Qbackground_pixmap, face->background_pixmap, result);
237 result = cons3(Qdisplay_table, face->display_table, result);
238 result = cons3(Qfont, face->font, result);
239 result = cons3(Qbackground, face->background, result);
240 result = cons3(Qforeground, face->foreground, result);
245 static const struct lrecord_description face_description[] = {
246 {XD_LISP_OBJECT, offsetof(Lisp_Face, name)},
247 {XD_LISP_OBJECT, offsetof(Lisp_Face, doc_string)},
248 {XD_LISP_OBJECT, offsetof(Lisp_Face, foreground)},
249 {XD_LISP_OBJECT, offsetof(Lisp_Face, background)},
250 {XD_LISP_OBJECT, offsetof(Lisp_Face, font)},
251 {XD_LISP_OBJECT, offsetof(Lisp_Face, display_table)},
252 {XD_LISP_OBJECT, offsetof(Lisp_Face, background_pixmap)},
253 {XD_LISP_OBJECT, offsetof(Lisp_Face, underline)},
254 {XD_LISP_OBJECT, offsetof(Lisp_Face, strikethru)},
255 {XD_LISP_OBJECT, offsetof(Lisp_Face, highlight)},
256 {XD_LISP_OBJECT, offsetof(Lisp_Face, dim)},
257 {XD_LISP_OBJECT, offsetof(Lisp_Face, blinking)},
258 {XD_LISP_OBJECT, offsetof(Lisp_Face, reverse)},
259 {XD_LISP_OBJECT, offsetof(Lisp_Face, plist)},
260 {XD_LISP_OBJECT, offsetof(Lisp_Face, charsets_warned_about)},
264 DEFINE_LRECORD_IMPLEMENTATION_WITH_PROPS("face", face,
265 mark_face, print_face, 0, face_equal,
266 face_hash, face_description,
267 face_getprop, face_putprop,
268 face_remprop, face_plist, Lisp_Face);
270 /************************************************************************/
271 /* face read syntax */
272 /************************************************************************/
275 face_name_validate(Lisp_Object keyword, Lisp_Object value, Error_behavior errb)
277 if (ERRB_EQ(errb, ERROR_ME)) {
282 return SYMBOLP(value);
285 static int face_validate(Lisp_Object data, Error_behavior errb)
288 Lisp_Object valw = Qnil;
290 data = Fcdr(data); /* skip over Qface */
291 while (!NILP(data)) {
292 Lisp_Object keyw = Fcar(data);
304 maybe_error(Qface, errb, "No face name given");
308 if (NILP(Ffind_face(valw))) {
309 maybe_signal_simple_error("No such face", valw, Qface, errb);
316 static Lisp_Object face_instantiate(Lisp_Object data)
318 return Fget_face(Fcar(Fcdr(data)));
321 /****************************************************************************
322 * utility functions *
323 ****************************************************************************/
325 static void reset_face(Lisp_Face * f)
328 f->doc_string = Qnil;
330 f->foreground = Qnil;
331 f->background = Qnil;
333 f->display_table = Qnil;
334 f->background_pixmap = Qnil;
336 f->strikethru = Qnil;
342 f->charsets_warned_about = Qnil;
345 static Lisp_Face *allocate_face(void)
347 Lisp_Face *result = alloc_lcrecord_type(Lisp_Face, &lrecord_face);
353 /* We store the faces in hash tables with the names as the key and the
354 actual face object as the value. Occasionally we need to use them
355 in a list format. These routines provide us with that. */
356 struct face_list_closure {
357 Lisp_Object *face_list;
361 add_face_to_list_mapper(Lisp_Object key, Lisp_Object value,
362 void *face_list_closure)
364 /* This function can GC */
365 struct face_list_closure *fcl =
366 (struct face_list_closure *)face_list_closure;
368 *(fcl->face_list) = Fcons(XFACE(value)->name, (*fcl->face_list));
372 static Lisp_Object faces_list_internal(Lisp_Object list)
374 Lisp_Object face_list = Qnil;
376 struct face_list_closure face_list_closure;
379 face_list_closure.face_list = &face_list;
380 elisp_maphash(add_face_to_list_mapper, list, &face_list_closure);
386 static Lisp_Object permanent_faces_list(void)
388 return faces_list_internal(Vpermanent_faces_cache);
391 static Lisp_Object temporary_faces_list(void)
393 return faces_list_internal(Vtemporary_faces_cache);
397 mark_face_as_clean_mapper(Lisp_Object key, Lisp_Object value,
400 /* This function can GC */
401 int *flag = (int *)flag_closure;
402 XFACE(value)->dirty = *flag;
406 static void mark_all_faces_internal(int flag)
408 elisp_maphash(mark_face_as_clean_mapper, Vpermanent_faces_cache, &flag);
409 elisp_maphash(mark_face_as_clean_mapper, Vtemporary_faces_cache, &flag);
412 void mark_all_faces_as_clean(void)
414 mark_all_faces_internal(0);
417 /* Currently unused (see the comment in face_property_was_changed()). */
419 /* #### OBSOLETE ME, PLEASE. Maybe. Maybe this is just as good as
420 any other solution. */
421 struct face_inheritance_closure {
423 Lisp_Object property;
427 update_inheritance_mapper_internal(Lisp_Object cur_face,
428 Lisp_Object inh_face, Lisp_Object property)
430 /* #### fix this function */
431 Lisp_Object elt = Qnil;
436 for (elt = FACE_PROPERTY_SPEC_LIST(cur_face, property, Qall);
437 !NILP(elt); elt = XCDR(elt)) {
438 Lisp_Object values = XCDR(XCAR(elt));
440 for (; !NILP(values); values = XCDR(values)) {
441 Lisp_Object value = XCDR(XCAR(values));
442 if (VECTORP(value) && XVECTOR_LENGTH(value)) {
444 (Ffind_face(XVECTOR_DATA(value)[0]),
446 Fset_specifier_dirty_flag
447 (FACE_PROPERTY_SPECIFIER
448 (inh_face, property));
457 update_face_inheritance_mapper(const void *hash_key, void *hash_contents,
458 void *face_inheritance_closure)
460 Lisp_Object key, contents;
461 struct face_inheritance_closure *fcl =
462 (struct face_inheritance_closure *)face_inheritance_closure;
464 CVOID_TO_LISP(key, hash_key);
465 VOID_TO_LISP(contents, hash_contents);
467 if (EQ(fcl->property, Qfont)) {
468 update_inheritance_mapper_internal(contents, fcl->face, Qfont);
469 } else if (EQ(fcl->property, Qforeground) ||
470 EQ(fcl->property, Qbackground)) {
471 update_inheritance_mapper_internal(contents, fcl->face,
473 update_inheritance_mapper_internal(contents, fcl->face,
475 } else if (EQ(fcl->property, Qunderline)
476 || EQ(fcl->property, Qstrikethru)
477 || EQ(fcl->property, Qhighlight) || EQ(fcl->property, Qdim)
478 || EQ(fcl->property, Qblinking)
479 || EQ(fcl->property, Qreverse)) {
480 update_inheritance_mapper_internal(contents, fcl->face,
482 update_inheritance_mapper_internal(contents, fcl->face,
484 update_inheritance_mapper_internal(contents, fcl->face,
486 update_inheritance_mapper_internal(contents, fcl->face, Qdim);
487 update_inheritance_mapper_internal(contents, fcl->face,
489 update_inheritance_mapper_internal(contents, fcl->face,
495 static void update_faces_inheritance(Lisp_Object face, Lisp_Object property)
497 struct face_inheritance_closure face_inheritance_closure;
498 struct gcpro gcpro1, gcpro2;
500 GCPRO2(face, property);
501 face_inheritance_closure.face = face;
502 face_inheritance_closure.property = property;
504 elisp_maphash(update_face_inheritance_mapper, Vpermanent_faces_cache,
505 &face_inheritance_closure);
506 elisp_maphash(update_face_inheritance_mapper, Vtemporary_faces_cache,
507 &face_inheritance_closure);
514 face_property_matching_instance(Lisp_Object face, Lisp_Object property,
515 Lisp_Object charset, Lisp_Object domain,
516 Error_behavior errb, int no_fallback,
520 specifier_instance_no_quit(Fget(face, property, Qnil), charset,
521 domain, errb, no_fallback, depth);
523 if (UNBOUNDP(retval) && !no_fallback) {
524 if (EQ(property, Qfont)) {
525 if (NILP(memq_no_quit(charset,
527 charsets_warned_about))) {
529 if (!UNBOUNDP(charset))
532 "Unable to instantiate font for face %s, charset %s",
533 string_data(symbol_name
535 (XFACE(face)->name))),
536 string_data(symbol_name
542 warn_when_safe(Qfont, Qwarning,
543 "Unable to instantiate font for face %s",
544 string_data(symbol_name
549 XFACE(face)->charsets_warned_about =
551 XFACE(face)->charsets_warned_about);
553 retval = Vthe_null_font_instance;
560 DEFUN("facep", Ffacep, 1, 1, 0, /*
561 Return t if OBJECT is a face.
565 return FACEP(object) ? Qt : Qnil;
568 DEFUN("find-face", Ffind_face, 1, 1, 0, /*
569 Retrieve the face of the given name.
570 If FACE-OR-NAME is a face object, it is simply returned.
571 Otherwise, FACE-OR-NAME should be a symbol. If there is no such face,
572 nil is returned. Otherwise the associated face object is returned.
578 if (FACEP(face_or_name))
580 CHECK_SYMBOL(face_or_name);
582 /* Check if the name represents a permanent face. */
583 retval = Fgethash(face_or_name, Vpermanent_faces_cache, Qnil);
587 /* Check if the name represents a temporary face. */
588 return Fgethash(face_or_name, Vtemporary_faces_cache, Qnil);
591 DEFUN("get-face", Fget_face, 1, 1, 0, /*
592 Retrieve the face of the given name.
593 Same as `find-face' except an error is signalled if there is no such
594 face instead of returning nil.
598 Lisp_Object face = Ffind_face(name);
601 signal_simple_error("No such face", name);
605 DEFUN("face-name", Fface_name, 1, 1, 0, /*
606 Return the name of the given face.
610 Lisp_Object tmp_face = Fget_face(face);
611 return XFACE(tmp_face)->name;
614 DEFUN("built-in-face-specifiers", Fbuilt_in_face_specifiers, 0, 0, 0, /*
615 Return a list of all built-in face specifier properties.
616 Don't modify this list!
620 return Vbuilt_in_face_specifiers;
623 /* These values are retrieved so often that we make a special
628 default_face_font_info(Lisp_Object domain, int *ascent, int *descent,
629 int *height, int *width, int *proportional_p)
631 Lisp_Object font_instance;
633 if (noninteractive) {
647 /* We use ASCII here. This is probably reasonable because the
648 people calling this function are using the resulting values to
649 come up with overall sizes for windows and frames. */
650 if (WINDOWP(domain)) {
651 struct face_cachel *cachel;
652 struct window *w = XWINDOW(domain);
654 /* #### It's possible for this function to get called when the
655 face cachels have not been initialized. I don't know why. */
656 if (!Dynarr_length(w->face_cachels))
657 reset_face_cachels(w);
658 cachel = WINDOW_FACE_CACHEL(w, DEFAULT_INDEX);
659 font_instance = FACE_CACHEL_FONT(cachel, Vcharset_ascii);
662 FACE_FONT(Vdefault_face, domain, Vcharset_ascii);
666 *height = XFONT_INSTANCE(font_instance)->height;
668 *width = XFONT_INSTANCE(font_instance)->width;
670 *ascent = XFONT_INSTANCE(font_instance)->ascent;
672 *descent = XFONT_INSTANCE(font_instance)->descent;
674 *proportional_p = XFONT_INSTANCE(font_instance)->proportional_p;
677 void default_face_height_and_width(Lisp_Object domain, int *height, int *width)
679 default_face_font_info(domain, 0, 0, height, width, 0);
683 default_face_height_and_width_1(Lisp_Object domain, int *height, int *width)
685 if (window_system_pixelated_geometry(domain)) {
691 default_face_height_and_width(domain, height, width);
694 DEFUN("face-list", Fface_list, 0, 1, 0, /*
695 Return a list of the names of all defined faces.
696 If TEMPORARY is nil, only the permanent faces are included.
697 If it is t, only the temporary faces are included. If it is any
698 other non-nil value both permanent and temporary are included.
702 Lisp_Object face_list = Qnil;
704 /* Added the permanent faces, if requested. */
705 if (NILP(temporary) || !EQ(Qt, temporary))
706 face_list = permanent_faces_list();
708 if (!NILP(temporary)) {
711 face_list = nconc2(face_list, temporary_faces_list());
718 DEFUN("make-face", Fmake_face, 1, 3, 0, /*
719 Define a new face with name NAME (a symbol), described by DOC-STRING.
720 You can modify the font, color, etc. of a face with the set-face-* functions.
721 If the face already exists, it is unmodified.
722 If TEMPORARY is non-nil, this face will cease to exist if not in use.
724 (name, doc_string, temporary))
726 /* This function can GC if initialized is non-zero */
731 if (!NILP(doc_string))
732 CHECK_STRING(doc_string);
734 face = Ffind_face(name);
742 f->doc_string = doc_string;
743 f->foreground = Fmake_specifier(Qcolor);
744 set_color_attached_to(f->foreground, face, Qforeground);
745 f->background = Fmake_specifier(Qcolor);
746 set_color_attached_to(f->background, face, Qbackground);
747 f->font = Fmake_specifier(Qfont);
748 set_font_attached_to(f->font, face, Qfont);
749 f->background_pixmap = Fmake_specifier(Qimage);
750 set_image_attached_to(f->background_pixmap, face, Qbackground_pixmap);
751 f->display_table = Fmake_specifier(Qdisplay_table);
752 f->underline = Fmake_specifier(Qface_boolean);
753 set_face_boolean_attached_to(f->underline, face, Qunderline);
754 f->strikethru = Fmake_specifier(Qface_boolean);
755 set_face_boolean_attached_to(f->strikethru, face, Qstrikethru);
756 f->highlight = Fmake_specifier(Qface_boolean);
757 set_face_boolean_attached_to(f->highlight, face, Qhighlight);
758 f->dim = Fmake_specifier(Qface_boolean);
759 set_face_boolean_attached_to(f->dim, face, Qdim);
760 f->blinking = Fmake_specifier(Qface_boolean);
761 set_face_boolean_attached_to(f->blinking, face, Qblinking);
762 f->reverse = Fmake_specifier(Qface_boolean);
763 set_face_boolean_attached_to(f->reverse, face, Qreverse);
764 if (!NILP(Vdefault_face)) {
765 /* If the default face has already been created, set it as
766 the default fallback specifier for all the specifiers we
767 just created. This implements the standard "all faces
768 inherit from default" behavior. */
769 set_specifier_fallback(f->foreground,
770 Fget(Vdefault_face, Qforeground,
772 set_specifier_fallback(f->background,
773 Fget(Vdefault_face, Qbackground,
775 set_specifier_fallback(f->font,
776 Fget(Vdefault_face, Qfont, Qunbound));
777 set_specifier_fallback(f->background_pixmap,
778 Fget(Vdefault_face, Qbackground_pixmap,
780 set_specifier_fallback(f->display_table,
781 Fget(Vdefault_face, Qdisplay_table,
783 set_specifier_fallback(f->underline,
784 Fget(Vdefault_face, Qunderline,
786 set_specifier_fallback(f->strikethru,
787 Fget(Vdefault_face, Qstrikethru,
789 set_specifier_fallback(f->highlight,
790 Fget(Vdefault_face, Qhighlight,
792 set_specifier_fallback(f->dim,
793 Fget(Vdefault_face, Qdim, Qunbound));
794 set_specifier_fallback(f->blinking,
795 Fget(Vdefault_face, Qblinking,
797 set_specifier_fallback(f->reverse,
798 Fget(Vdefault_face, Qreverse, Qunbound));
801 /* Add the face to the appropriate list. */
803 Fputhash(name, face, Vpermanent_faces_cache);
805 Fputhash(name, face, Vtemporary_faces_cache);
807 /* Note that it's OK if we dump faces.
808 When we start up again when we're not noninteractive,
809 `init-global-faces' is called and it resources all
811 if (initialized && !noninteractive) {
812 struct gcpro gcpro1, gcpro2;
815 call1(Qinit_face_from_resources, name);
822 /*****************************************************************************
824 ****************************************************************************/
826 void init_global_faces(struct device *d)
828 /* When making the initial terminal device, there is no Lisp code
829 loaded, so we can't do this. */
830 if (initialized && !noninteractive) {
831 call_critical_lisp_code(d, Qinit_global_faces, Qnil);
835 void init_device_faces(struct device *d)
837 /* This function can call lisp */
839 /* When making the initial terminal device, there is no Lisp code
840 loaded, so we can't do this. */
843 XSETDEVICE(tdevice, d);
844 call_critical_lisp_code(d, Qinit_device_faces, tdevice);
848 void init_frame_faces(struct frame *frm)
850 /* When making the initial terminal device, there is no Lisp code
851 loaded, so we can't do this. */
854 XSETFRAME(tframe, frm);
856 /* DO NOT change the selected frame here. If the debugger goes off
857 it will try and display on the frame being created, but it is not
858 ready for that yet and a horrible death will occur. Any random
859 code depending on the selected-frame as an implicit arg should be
860 tracked down and shot. For the benefit of the one known,
861 xpm-color-symbols, make-frame sets the variable
862 Vframe_being_created to the frame it is making and sets it to nil
863 when done. Internal functions that this could trigger which are
864 currently depending on selected-frame should use this instead. It
865 is not currently visible at the lisp level. */
866 call_critical_lisp_code(XDEVICE(FRAME_DEVICE(frm)),
867 Qinit_frame_faces, tframe);
871 /****************************************************************************
872 * face cache element functions *
873 ****************************************************************************/
877 #### Here is a description of how the face cache elements ought
878 to be redone. It is *NOT* how they work currently:
880 However, when I started to go about implementing this, I realized
881 that there are all sorts of subtle problems with cache coherency
882 that are coming up. As it turns out, these problems don't
883 manifest themselves now due to the brute-force "kill 'em all"
884 approach to cache invalidation when faces change; but if this
885 is ever made smarter, these problems are going to come up, and
886 some of them are very non-obvious.
888 I'm thinking of redoing the cache code a bit to avoid these
889 coherency problems. The bulk of the problems will arise because
890 the current display structures have simple indices into the
891 face cache, but the cache can be changed at various times,
892 which could make the current display structures incorrect.
893 I guess the dirty and updated flags are an attempt to fix
894 this, but this approach doesn't really work.
896 Here's an approach that should keep things clean and unconfused:
898 1) Imagine a "virtual face cache" that can grow arbitrarily
899 big and for which the only thing allowed is to add new
900 elements. Existing elements cannot be removed or changed.
901 This way, any pointers in the existing redisplay structure
902 into the cache never get screwed up. (This is important
903 because even if a cache element is out of date, if there's
904 a pointer to it then its contents still accurately describe
905 the way the text currently looks on the screen.)
906 2) Each element in the virtual cache either describes exactly
907 one face, or describes the merger of a number of faces
908 by some process. In order to simplify things, for mergers
909 we do not record which faces or ordering was used, but
910 simply that this cache element is the result of merging.
911 Unlike the current implementation, it's important that a
912 single cache element not be used to both describe a
913 single face and describe a merger, even if all the property
915 3) Each cache element can be clean or dirty. "Dirty" means
916 that the face that the element points to has been changed;
917 this gets set at the time the face is changed. This
918 way, when looking up a value in the cache, you can determine
919 whether it's out of date or not. For merged faces it
920 does not matter -- we don't record the faces or priority
921 used to create the merger, so it's impossible to look up
922 one of these faces. We have to recompute it each time.
923 Luckily, this is fine -- doing the merge is much
924 less expensive than recomputing the properties of a
926 4) For each cache element, we keep a hash value. (In order
927 to hash the boolean properties, we convert each of them
928 into a different large prime number so that the hashing works
929 well.) This allows us, when comparing runes, to properly
930 determine whether the face for that rune has changed.
931 This will be especially important for TTY's, where there
932 aren't that many faces and minimizing redraw is very
934 5) We can't actually keep an infinite cache, but that doesn't
935 really matter that much. The only elements we care about
936 are those that are used by either the current or desired
937 display structs. Therefore, we keep a per-window
938 redisplay iteration number, and mark each element with
939 that number as we use it. Just after outputting the
940 window and synching the redisplay structs, we go through
941 the cache and invalidate all elements that are not clean
942 elements referring to a particular face and that do not
943 have an iteration number equal to the current one. We
944 keep them in a chain, and use them to allocate new
945 elements when possible instead of increasing the Dynarr.
949 /* mark for GC a dynarr of face cachels. */
951 void mark_face_cachels(face_cachel_dynarr * elements)
958 for (elt = 0; elt < Dynarr_length(elements); elt++) {
959 struct face_cachel *cachel = Dynarr_atp(elements, elt);
964 for (i = 0; i < NUM_LEADING_BYTES; i++)
965 if (!NILP(cachel->font[i])
966 && !UNBOUNDP(cachel->font[i]))
967 mark_object(cachel->font[i]);
969 mark_object(cachel->face);
970 mark_object(cachel->foreground);
971 mark_object(cachel->background);
972 mark_object(cachel->display_table);
973 mark_object(cachel->background_pixmap);
977 /* ensure that the given cachel contains an updated font value for
978 the given charset. Return the updated font value. */
981 ensure_face_cachel_contains_charset(struct face_cachel *cachel,
982 Lisp_Object domain, Lisp_Object charset)
985 Lisp_Object face = cachel->face;
987 int offs = XCHARSET_LEADING_BYTE(charset) - MIN_LEADING_BYTE;
989 if (!UNBOUNDP(cachel->font[offs])
990 && cachel->font_updated[offs])
991 return cachel->font[offs];
993 if (UNBOUNDP(face)) {
996 struct window *w = XWINDOW(domain);
999 cachel->font_specified[offs] = 0;
1000 for (i = 0; i < cachel->nfaces; i++) {
1001 struct face_cachel *oth;
1003 oth = Dynarr_atp(w->face_cachels,
1004 FACE_CACHEL_FINDEX_UNSAFE(cachel, i));
1005 /* Tout le monde aime la recursion */
1006 ensure_face_cachel_contains_charset(oth, domain,
1009 if (oth->font_specified[offs]) {
1010 new_val = oth->font[offs];
1011 cachel->font_specified[offs] = 1;
1016 if (!cachel->font_specified[offs])
1017 /* need to do the default face. */
1019 struct face_cachel *oth =
1020 Dynarr_atp(w->face_cachels, DEFAULT_INDEX);
1021 ensure_face_cachel_contains_charset(oth, domain,
1024 new_val = oth->font[offs];
1027 if (!UNBOUNDP(cachel->font[offs])
1028 && !EQ(cachel->font[offs], new_val))
1030 cachel->font_updated[offs] = 1;
1031 cachel->font[offs] = new_val;
1035 new_val = face_property_matching_instance(face, Qfont, charset, domain,
1036 /* #### look into ERROR_ME_NOT */
1037 ERROR_ME_NOT, 1, Qzero);
1038 if (UNBOUNDP(new_val)) {
1040 new_val = face_property_matching_instance(face, Qfont,
1047 if (!UNBOUNDP(cachel->font[offs]) && !EQ(new_val, cachel->font[offs]))
1049 cachel->font_updated[offs] = 1;
1050 cachel->font[offs] = new_val;
1051 cachel->font_specified[offs] = (bound || EQ(face, Vdefault_face));
1055 /* Ensure that the given cachel contains updated fonts for all
1056 the charsets specified. */
1059 ensure_face_cachel_complete(struct face_cachel *cachel,
1060 Lisp_Object domain, unsigned char *charsets)
1064 for (i = 0; i < NUM_LEADING_BYTES; i++)
1066 Lisp_Object charset =
1067 CHARSET_BY_LEADING_BYTE(i + MIN_LEADING_BYTE);
1068 assert(CHARSETP(charset));
1069 ensure_face_cachel_contains_charset(cachel, domain,
1075 face_cachel_charset_font_metric_info(struct face_cachel *cachel,
1076 unsigned char *charsets,
1077 struct font_metric_info *fm)
1082 fm->height = fm->ascent = 1;
1084 fm->proportional_p = 0;
1086 for (i = 0; i < NUM_LEADING_BYTES; i++) {
1088 Lisp_Object charset =
1089 CHARSET_BY_LEADING_BYTE(i + MIN_LEADING_BYTE);
1090 Lisp_Object font_instance =
1091 FACE_CACHEL_FONT(cachel, charset);
1092 Lisp_Font_Instance *fi = XFONT_INSTANCE(font_instance);
1094 assert(CHARSETP(charset));
1095 assert(FONT_INSTANCEP(font_instance));
1097 if (fm->ascent < (int)fi->ascent)
1098 fm->ascent = (int)fi->ascent;
1099 if (fm->descent < (int)fi->descent)
1100 fm->descent = (int)fi->descent;
1101 fm->height = fm->ascent + fm->descent;
1102 if (fi->proportional_p)
1103 fm->proportional_p = 1;
1104 if (EQ(charset, Vcharset_ascii))
1105 fm->width = fi->width;
1110 #define FROB(field) \
1112 Lisp_Object new_val = \
1113 FACE_PROPERTY_INSTANCE (face, Q##field, domain, 1, Qzero); \
1115 if (UNBOUNDP (new_val)) \
1118 new_val = FACE_PROPERTY_INSTANCE (face, Q##field, domain, 0, Qzero); \
1120 if (!EQ (new_val, cachel->field)) \
1122 cachel->field = new_val; \
1123 cachel->dirty = 1; \
1125 cachel->field##_specified = (bound || default_face); \
1129 * A face's background pixmap will override the face's
1130 * background color. But the background pixmap of the
1131 * default face should not override the background color of
1132 * a face if the background color has been specified or
1135 * To accomplish this we remove the background pixmap of the
1136 * cachel and mark it as having been specified so that cachel
1137 * merging won't override it later.
1139 #define MAYBE_UNFROB_BACKGROUND_PIXMAP \
1142 if (! default_face \
1143 && cachel->background_specified \
1144 && ! cachel->background_pixmap_specified) \
1146 cachel->background_pixmap = Qunbound; \
1147 cachel->background_pixmap_specified = 1; \
1151 /* Add a cachel for the given face to the given window's cache. */
1153 static void add_face_cachel(struct window *w, Lisp_Object face)
1155 int must_finish_frobbing = !WINDOW_FACE_CACHEL(w, DEFAULT_INDEX);
1156 struct face_cachel new_cachel;
1159 reset_face_cachel(&new_cachel);
1160 XSETWINDOW(domain, w);
1161 update_face_cachel_data(&new_cachel, domain, face);
1162 Dynarr_add(w->face_cachels, new_cachel);
1164 /* The face's background pixmap have not yet been frobbed (see comment
1165 int update_face_cachel_data), so we have to do it now */
1166 if (must_finish_frobbing) {
1167 int default_face = EQ(face, Vdefault_face);
1168 struct face_cachel *cachel
1170 Dynarr_atp(w->face_cachels,
1171 Dynarr_length(w->face_cachels) - 1);
1173 FROB(background_pixmap);
1174 MAYBE_UNFROB_BACKGROUND_PIXMAP;
1178 /* Called when the updated flag has been cleared on a cachel.
1179 This function returns 1 if the caller must finish the update (see comment
1180 below), 0 otherwise.
1184 update_face_cachel_data(struct face_cachel *cachel,
1185 Lisp_Object domain, Lisp_Object face)
1187 if (XFACE(face)->dirty || UNBOUNDP(cachel->face)) {
1188 int default_face = EQ(face, Vdefault_face);
1189 cachel->face = face;
1191 /* We normally only set the _specified flags if the value was
1192 actually bound. The exception is for the default face where
1193 we always set it since it is the ultimate fallback. */
1197 FROB(display_table);
1199 /* #### WARNING: the background pixmap property of faces is currently
1200 the only one dealing with images. The problem we have here is that
1201 frobbing the background pixmap might lead to image instantiation
1202 which in turn might require that the cache we're building be up to
1203 date, hence a crash. Here's a typical scenario of this:
1205 - a new window is created and it's face cache elements are
1206 initialized through a call to reset_face_cachels[1]. At that point,
1207 the cache for the default and modeline faces (normaly taken care of
1208 by redisplay itself) are null.
1209 - the default face has a background pixmap which needs to be
1210 instantiated right here, as a consequence of cache initialization.
1211 - the background pixmap image happens to be instantiated as a string
1212 (this happens on tty's for instance).
1213 - In order to do this, we need to compute the string geometry.
1214 - In order to do this, we might have to access the window's default
1215 face cache. But this is the cache we're building right now, it is
1219 To sum up, this means that it is in general unsafe to instantiate
1220 images before face cache updating is complete (appart from image
1221 related face attributes). The solution we use below is to actually
1222 detect whether we're building the window's face_cachels for the first
1223 time, and simply NOT frob the background pixmap in that case. If
1224 other image-related face attributes are ever implemented, they should
1225 be protected the same way right here.
1228 * See comment in `default_face_font_info' in face.c. Who wrote it ?
1229 Maybe we have the begining of an answer here ?
1232 [1] See comment at the top of `allocate_window' in window.c.
1236 if (!WINDOWP(domain)
1237 || WINDOW_FACE_CACHEL(DOMAIN_XWINDOW(domain),
1239 FROB(background_pixmap);
1240 MAYBE_UNFROB_BACKGROUND_PIXMAP;
1243 #undef MAYBE_UNFROB_BACKGROUND_PIXMAP
1245 ensure_face_cachel_contains_charset(cachel, domain,
1248 #define FROB(field) \
1250 Lisp_Object new_val = \
1251 FACE_PROPERTY_INSTANCE (face, Q##field, domain, 1, Qzero); \
1253 unsigned int new_val_int; \
1254 if (UNBOUNDP (new_val)) \
1257 new_val = FACE_PROPERTY_INSTANCE (face, Q##field, domain, 0, Qzero); \
1259 new_val_int = EQ (new_val, Qt); \
1260 if (cachel->field != new_val_int) \
1262 cachel->field = new_val_int; \
1263 cachel->dirty = 1; \
1265 cachel->field##_specified = bound; \
1277 cachel->updated = 1;
1280 /* Merge the cachel identified by FINDEX in window W into the given
1284 merge_face_cachel_data(struct window *w, face_index findex,
1285 struct face_cachel *cachel)
1287 #define FINDEX_FIELD(field) \
1288 Dynarr_atp (w->face_cachels, findex)->field
1290 #define FROB(field) \
1292 if (!cachel->field##_specified && FINDEX_FIELD (field##_specified)) \
1294 cachel->field = FINDEX_FIELD (field); \
1295 cachel->field##_specified = 1; \
1296 cachel->dirty = 1; \
1302 FROB(display_table);
1303 FROB(background_pixmap);
1310 /* And do ASCII, of course. */
1312 int offs = LEADING_BYTE_ASCII - MIN_LEADING_BYTE;
1314 if (!cachel->font_specified[offs]
1315 && FINDEX_FIELD(font_specified[offs])) {
1316 cachel->font[offs] = FINDEX_FIELD(font[offs]);
1317 cachel->font_specified[offs] = 1;
1325 cachel->updated = 1;
1328 /* Initialize a cachel. */
1330 void reset_face_cachel(struct face_cachel *cachel)
1333 cachel->face = Qunbound;
1335 cachel->merged_faces = 0;
1336 cachel->foreground = Qunbound;
1337 cachel->background = Qunbound;
1341 for (i = 0; i < NUM_LEADING_BYTES; i++)
1342 cachel->font[i] = Qunbound;
1344 cachel->display_table = Qunbound;
1345 cachel->background_pixmap = Qunbound;
1348 /* Retrieve the index to a cachel for window W that corresponds to
1349 the specified face. If necessary, add a new element to the
1352 face_index get_builtin_face_cache_index(struct window *w, Lisp_Object face)
1359 for (elt = 0; elt < Dynarr_length(w->face_cachels); elt++) {
1360 struct face_cachel *cachel = WINDOW_FACE_CACHEL(w, elt);
1362 if (EQ(cachel->face, face)) {
1364 XSETWINDOW(window, w);
1365 if (!cachel->updated)
1366 update_face_cachel_data(cachel, window, face);
1371 /* If we didn't find the face, add it and then return its index. */
1372 add_face_cachel(w, face);
1376 void reset_face_cachels(struct window *w)
1378 /* #### Not initialized in batch mode for the stream device. */
1379 if (w->face_cachels) {
1382 for (i = 0; i < Dynarr_length(w->face_cachels); i++) {
1383 struct face_cachel *cachel =
1384 Dynarr_atp(w->face_cachels, i);
1385 if (cachel->merged_faces)
1386 Dynarr_free(cachel->merged_faces);
1388 Dynarr_reset(w->face_cachels);
1389 get_builtin_face_cache_index(w, Vdefault_face);
1390 get_builtin_face_cache_index(w, Vmodeline_face);
1391 XFRAME(w->frame)->window_face_cache_reset = 1;
1395 void mark_face_cachels_as_clean(struct window *w)
1399 for (elt = 0; elt < Dynarr_length(w->face_cachels); elt++)
1400 Dynarr_atp(w->face_cachels, elt)->dirty = 0;
1403 void mark_face_cachels_as_not_updated(struct window *w)
1407 for (elt = 0; elt < Dynarr_length(w->face_cachels); elt++) {
1408 struct face_cachel *cachel = Dynarr_atp(w->face_cachels, elt);
1411 cachel->updated = 0;
1412 for (i = 0; i < NUM_LEADING_BYTES; i++)
1413 cachel->font_updated[i] = 0;
1417 #if defined MEMORY_USAGE_STATS && !(defined HAVE_BDWGC && defined EF_USE_BDWGC)
1420 compute_face_cachel_usage(face_cachel_dynarr * face_cachels,
1421 struct overhead_stats *ovstats)
1428 total += Dynarr_memory_usage(face_cachels, ovstats);
1429 for (i = 0; i < Dynarr_length(face_cachels); i++) {
1430 int_dynarr *merged =
1431 Dynarr_at(face_cachels, i).merged_faces;
1433 total += Dynarr_memory_usage(merged, ovstats);
1440 #endif /* MEMORY_USAGE_STATS */
1442 /*****************************************************************************
1443 * merged face functions *
1444 *****************************************************************************/
1446 /* Compare two merged face cachels to determine whether we have to add
1447 a new entry to the face cache.
1449 Note that we do not compare the attributes, but just the faces the
1450 cachels are based on. If they are the same, then the cachels certainly
1451 ought to have the same attributes, except in the case where fonts
1452 for different charsets have been determined in the two -- and in that
1453 case this difference is fine. */
1456 compare_merged_face_cachels(struct face_cachel *cachel1,
1457 struct face_cachel *cachel2)
1461 if (!EQ(cachel1->face, cachel2->face)
1462 || cachel1->nfaces != cachel2->nfaces)
1465 for (i = 0; i < cachel1->nfaces; i++)
1466 if (FACE_CACHEL_FINDEX_UNSAFE(cachel1, i)
1467 != FACE_CACHEL_FINDEX_UNSAFE(cachel2, i))
1473 /* Retrieve the index to a cachel for window W that corresponds to
1474 the specified cachel. If necessary, add a new element to the
1475 cache. This is similar to get_builtin_face_cache_index() but
1476 is intended for merged cachels rather than for cachels representing
1479 Note that a merged cachel for just one face is not the same as
1480 the simple cachel for that face, because it is also merged with
1481 the default face. */
1484 get_merged_face_cache_index(struct window *w, struct face_cachel *merged_cachel)
1487 int cache_size = Dynarr_length(w->face_cachels);
1489 for (elt = 0; elt < cache_size; elt++) {
1490 struct face_cachel *cachel = Dynarr_atp(w->face_cachels, elt);
1492 if (compare_merged_face_cachels(cachel, merged_cachel))
1496 /* We didn't find it so add this instance to the cache. */
1497 merged_cachel->updated = 1;
1498 merged_cachel->dirty = 1;
1499 Dynarr_add(w->face_cachels, *merged_cachel);
1504 get_extent_fragment_face_cache_index(struct window * w,
1505 struct extent_fragment * ef)
1507 struct face_cachel cachel;
1508 int len = Dynarr_length(ef->extents);
1509 face_index findex = 0;
1511 XSETWINDOW(window, w);
1513 /* Optimize the default case. */
1515 return DEFAULT_INDEX;
1519 /* Merge the faces of the extents together in order. */
1521 reset_face_cachel(&cachel);
1523 for (i = len - 1; i >= 0; i--) {
1524 EXTENT current = Dynarr_at(ef->extents, i);
1526 Lisp_Object face = extent_face(current);
1529 findex = get_builtin_face_cache_index(w, face);
1531 merge_face_cachel_data(w, findex, &cachel);
1533 /* remember, we're called from within redisplay
1534 so we can't error. */
1536 while (CONSP(face)) {
1537 Lisp_Object one_face = XCAR(face);
1538 if (FACEP(one_face)) {
1540 get_builtin_face_cache_index
1542 merge_face_cachel_data(w,
1546 /* code duplication here but there's no clean
1548 if (cachel.nfaces >=
1549 NUM_STATIC_CACHEL_FACES) {
1571 if (cachel.nfaces >= NUM_STATIC_CACHEL_FACES) {
1572 if (!cachel.merged_faces)
1573 cachel.merged_faces =
1575 Dynarr_add(cachel.merged_faces, findex);
1577 cachel.merged_faces_static[cachel.
1584 /* Now finally merge in the default face. */
1585 findex = get_builtin_face_cache_index(w, Vdefault_face);
1586 merge_face_cachel_data(w, findex, &cachel);
1588 findex = get_merged_face_cache_index(w, &cachel);
1589 if (cachel.merged_faces &&
1590 /* merged_faces did not get stored and available via return value */
1591 Dynarr_at(w->face_cachels, findex).merged_faces !=
1592 cachel.merged_faces) {
1593 Dynarr_free(cachel.merged_faces);
1594 cachel.merged_faces = 0;
1600 /*****************************************************************************
1602 ****************************************************************************/
1604 static void update_EmacsFrame(Lisp_Object frame, Lisp_Object name)
1606 struct frame *frm = XFRAME(frame);
1608 if (EQ(name, Qfont))
1609 MARK_FRAME_SIZE_SLIPPED(frm);
1611 MAYBE_FRAMEMETH(frm, update_frame_external_traits, (frm, name));
1614 static void update_EmacsFrames(Lisp_Object locale, Lisp_Object name)
1616 if (FRAMEP(locale)) {
1617 update_EmacsFrame(locale, name);
1618 } else if (DEVICEP(locale)) {
1619 Lisp_Object frmcons;
1621 DEVICE_FRAME_LOOP(frmcons, XDEVICE(locale))
1622 update_EmacsFrame(XCAR(frmcons), name);
1623 } else if (EQ(locale, Qglobal) || EQ(locale, Qfallback)) {
1624 Lisp_Object frmcons, devcons, concons;
1626 FRAME_LOOP_NO_BREAK(frmcons, devcons, concons)
1627 update_EmacsFrame(XCAR(frmcons), name);
1631 void update_frame_face_values(struct frame *f)
1636 update_EmacsFrame(frm, Qforeground);
1637 update_EmacsFrame(frm, Qbackground);
1638 update_EmacsFrame(frm, Qfont);
1642 face_property_was_changed(Lisp_Object face, Lisp_Object property,
1645 int default_face = EQ(face, Vdefault_face);
1647 /* If the locale could affect the frame value, then call
1648 update_EmacsFrames just in case. */
1650 (EQ(property, Qforeground) ||
1651 EQ(property, Qbackground) || EQ(property, Qfont)))
1652 update_EmacsFrames(locale, property);
1654 if (WINDOWP(locale)) {
1655 MARK_FRAME_FACES_CHANGED(XFRAME(XWINDOW(locale)->frame));
1656 } else if (FRAMEP(locale)) {
1657 MARK_FRAME_FACES_CHANGED(XFRAME(locale));
1658 } else if (DEVICEP(locale)) {
1659 MARK_DEVICE_FRAMES_FACES_CHANGED(XDEVICE(locale));
1661 Lisp_Object devcons, concons;
1662 DEVICE_LOOP_NO_BREAK(devcons, concons)
1663 MARK_DEVICE_FRAMES_FACES_CHANGED(XDEVICE(XCAR(devcons)));
1667 * This call to update_faces_inheritance isn't needed and makes
1668 * creating and modifying faces _very_ slow. The point of
1669 * update_face_inheritances is to find all faces that inherit
1670 * directly from this face property and set the specifier "dirty"
1671 * flag on the corresponding specifier. This forces recaching of
1672 * cached specifier values in frame and window struct slots. But
1673 * currently no face properties are cached in frame and window
1674 * struct slots, so calling this function does nothing useful!
1676 * Further, since update_faces_inheritance maps over the whole
1677 * face table every time it is called, it gets terribly slow when
1678 * there are many faces. Creating 500 faces on a 50Mhz 486 took
1679 * 433 seconds when update_faces_inheritance was called. With the
1680 * call commented out, creating those same 500 faces took 0.72
1683 /* update_faces_inheritance (face, property); */
1684 XFACE(face)->dirty = 1;
1687 DEFUN("copy-face", Fcopy_face, 2, 6, 0, /*
1688 Define and return a new face which is a copy of an existing one,
1689 or makes an already-existing face be exactly like another.
1690 LOCALE, TAG-SET, EXACT-P, and HOW-TO-ADD are as in `copy-specifier'.
1692 (old_face, new_name, locale, tag_set, exact_p, how_to_add))
1694 Lisp_Face *fold, *fnew;
1695 Lisp_Object new_face = Qnil;
1696 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
1698 old_face = Fget_face(old_face);
1700 /* We GCPRO old_face because it might be temporary, and GCing could
1701 occur in various places below. */
1702 GCPRO4(tag_set, locale, old_face, new_face);
1703 /* check validity of how_to_add now. */
1704 decode_how_to_add_specification(how_to_add);
1705 /* and of tag_set. */
1706 tag_set = decode_specifier_tag_set(tag_set);
1707 /* and of locale. */
1708 locale = decode_locale_list(locale);
1710 new_face = Ffind_face(new_name);
1711 if (NILP(new_face)) {
1714 CHECK_SYMBOL(new_name);
1716 /* Create the new face with the same status as the old face. */
1717 temp = (NILP(Fgethash(old_face, Vtemporary_faces_cache, Qnil))
1720 new_face = Fmake_face(new_name, Qnil, temp);
1723 fold = XFACE(old_face);
1724 fnew = XFACE(new_face);
1726 #define COPY_PROPERTY(property) \
1727 Fcopy_specifier (fold->property, fnew->property, \
1728 locale, tag_set, exact_p, how_to_add);
1730 COPY_PROPERTY(foreground);
1731 COPY_PROPERTY(background);
1732 COPY_PROPERTY(font);
1733 COPY_PROPERTY(display_table);
1734 COPY_PROPERTY(background_pixmap);
1735 COPY_PROPERTY(underline);
1736 COPY_PROPERTY(strikethru);
1737 COPY_PROPERTY(highlight);
1739 COPY_PROPERTY(blinking);
1740 COPY_PROPERTY(reverse);
1741 #undef COPY_PROPERTY
1742 /* #### should it copy the individual specifiers, if they exist? */
1743 fnew->plist = Fcopy_sequence(fold->plist);
1750 void syms_of_faces(void)
1752 INIT_LRECORD_IMPLEMENTATION(face);
1754 /* Qdefault, Qwidget, Qleft_margin, Qright_margin defined in general.c */
1755 defsymbol(&Qmodeline, "modeline");
1756 defsymbol(&Qgui_element, "gui-element");
1757 defsymbol(&Qtext_cursor, "text-cursor");
1758 defsymbol(&Qvertical_divider, "vertical-divider");
1761 DEFSUBR(Ffind_face);
1763 DEFSUBR(Fface_name);
1764 DEFSUBR(Fbuilt_in_face_specifiers);
1765 DEFSUBR(Fface_list);
1766 DEFSUBR(Fmake_face);
1767 DEFSUBR(Fcopy_face);
1769 defsymbol(&Qfacep, "facep");
1770 defsymbol(&Qforeground, "foreground");
1771 defsymbol(&Qbackground, "background");
1772 /* Qfont defined in general.c */
1773 defsymbol(&Qdisplay_table, "display-table");
1774 defsymbol(&Qbackground_pixmap, "background-pixmap");
1775 defsymbol(&Qunderline, "underline");
1776 defsymbol(&Qstrikethru, "strikethru");
1777 /* Qhighlight, Qreverse defined in general.c */
1778 defsymbol(&Qdim, "dim");
1779 defsymbol(&Qblinking, "blinking");
1781 defsymbol(&Qinit_face_from_resources, "init-face-from-resources");
1782 defsymbol(&Qinit_global_faces, "init-global-faces");
1783 defsymbol(&Qinit_device_faces, "init-device-faces");
1784 defsymbol(&Qinit_frame_faces, "init-frame-faces");
1787 void structure_type_create_faces(void)
1789 struct structure_type *st;
1791 st = define_structure_type(Qface, face_validate, face_instantiate);
1793 define_structure_type_keyword(st, Qname, face_name_validate);
1796 void vars_of_faces(void)
1798 staticpro(&Vpermanent_faces_cache);
1799 Vpermanent_faces_cache = Qnil;
1800 staticpro(&Vtemporary_faces_cache);
1801 Vtemporary_faces_cache = Qnil;
1803 staticpro(&Vdefault_face);
1804 Vdefault_face = Qnil;
1805 staticpro(&Vgui_element_face);
1806 Vgui_element_face = Qnil;
1807 staticpro(&Vwidget_face);
1808 Vwidget_face = Qnil;
1809 staticpro(&Vmodeline_face);
1810 Vmodeline_face = Qnil;
1811 staticpro(&Vtoolbar_face);
1812 Vtoolbar_face = Qnil;
1814 staticpro(&Vvertical_divider_face);
1815 Vvertical_divider_face = Qnil;
1816 staticpro(&Vleft_margin_face);
1817 Vleft_margin_face = Qnil;
1818 staticpro(&Vright_margin_face);
1819 Vright_margin_face = Qnil;
1820 staticpro(&Vtext_cursor_face);
1821 Vtext_cursor_face = Qnil;
1822 staticpro(&Vpointer_face);
1823 Vpointer_face = Qnil;
1826 Lisp_Object syms[20];
1829 syms[n++] = Qforeground;
1830 syms[n++] = Qbackground;
1832 syms[n++] = Qdisplay_table;
1833 syms[n++] = Qbackground_pixmap;
1834 syms[n++] = Qunderline;
1835 syms[n++] = Qstrikethru;
1836 syms[n++] = Qhighlight;
1838 syms[n++] = Qblinking;
1839 syms[n++] = Qreverse;
1841 Vbuilt_in_face_specifiers = Flist(n, syms);
1842 staticpro(&Vbuilt_in_face_specifiers);
1846 void complex_vars_of_faces(void)
1848 Vpermanent_faces_cache =
1849 make_lisp_hash_table(10, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
1850 Vtemporary_faces_cache =
1851 make_lisp_hash_table(0, HASH_TABLE_WEAK, HASH_TABLE_EQ);
1853 /* Create the default face now so we know what it is immediately. */
1855 Vdefault_face = Qnil; /* so that Fmake_face() doesn't set up a bogus
1857 Vdefault_face = Fmake_face(Qdefault, build_string("default face"),
1860 /* Provide some last-resort fallbacks to avoid utter fuckage if
1861 someone provides invalid values for the global specifications. */
1864 Lisp_Object fg_fb = Qnil, bg_fb = Qnil;
1866 #ifdef HAVE_X_WINDOWS
1867 fg_fb = acons(list1(Qx), build_string("black"), fg_fb);
1868 bg_fb = acons(list1(Qx), build_string("white"), bg_fb);
1871 fg_fb = acons(list1(Qtty), Fvector(0, 0), fg_fb);
1872 bg_fb = acons(list1(Qtty), Fvector(0, 0), bg_fb);
1874 set_specifier_fallback(Fget(Vdefault_face, Qforeground, Qnil),
1876 set_specifier_fallback(Fget(Vdefault_face, Qbackground, Qnil),
1880 /* #### We may want to have different fallback values if NeXTstep
1881 support is compiled in. */
1883 Lisp_Object inst_list = Qnil;
1885 #ifdef HAVE_X_WINDOWS
1886 /* This is kind of ugly because stephen wanted this to be CPP
1887 ** identical to the old version, at least for the initial
1890 ** WMP March 9, 2001
1893 /* The same gory list from x-faces.el.
1894 (#### Perhaps we should remove the stuff from x-faces.el
1895 and only depend on this stuff here? That should work.)
1897 const char *fonts[] = {
1898 "-*-courier-medium-r-*-*-*-120-*-*-*-*-iso8859-*",
1899 "-*-courier-medium-r-*-*-*-120-*-*-*-*-iso8859-*",
1900 "-*-courier-*-r-*-*-*-120-*-*-*-*-iso8859-*",
1901 "-*-*-medium-r-*-*-*-120-*-*-m-*-iso8859-*",
1902 "-*-*-medium-r-*-*-*-120-*-*-c-*-iso8859-*",
1903 "-*-*-*-r-*-*-*-120-*-*-m-*-iso8859-*",
1904 "-*-*-*-r-*-*-*-120-*-*-c-*-iso8859-*",
1905 "-*-*-*-r-*-*-*-120-*-*-*-*-iso8859-*",
1906 "-*-*-medium-r-*-*-*-120-*-*-m-*-*-*",
1907 "-*-*-medium-r-*-*-*-120-*-*-c-*-*-*",
1908 "-*-*-*-r-*-*-*-120-*-*-m-*-*-*",
1909 "-*-*-*-r-*-*-*-120-*-*-c-*-*-*",
1910 "-*-*-*-r-*-*-*-120-*-*-*-*-*-*",
1911 "-*-*-*-*-*-*-*-120-*-*-*-*-*-*",
1914 const char **fontptr;
1916 for (fontptr = fonts + countof(fonts) - 1; fontptr >= fonts;
1919 Fcons(Fcons(list1(Qx), build_string(*fontptr)),
1921 #endif /* HAVE_X_WINDOWS */
1924 inst_list = Fcons(Fcons(list1(Qtty), build_string("normal")),
1926 #endif /* HAVE_TTY */
1927 set_specifier_fallback(Fget(Vdefault_face, Qfont, Qnil),
1931 set_specifier_fallback(Fget(Vdefault_face, Qunderline, Qnil),
1932 list1(Fcons(Qnil, Qnil)));
1933 set_specifier_fallback(Fget(Vdefault_face, Qstrikethru, Qnil),
1934 list1(Fcons(Qnil, Qnil)));
1935 set_specifier_fallback(Fget(Vdefault_face, Qhighlight, Qnil),
1936 list1(Fcons(Qnil, Qnil)));
1937 set_specifier_fallback(Fget(Vdefault_face, Qdim, Qnil),
1938 list1(Fcons(Qnil, Qnil)));
1939 set_specifier_fallback(Fget(Vdefault_face, Qblinking, Qnil),
1940 list1(Fcons(Qnil, Qnil)));
1941 set_specifier_fallback(Fget(Vdefault_face, Qreverse, Qnil),
1942 list1(Fcons(Qnil, Qnil)));
1944 /* gui-element is the parent face of all gui elements such as
1945 modeline, vertical divider and toolbar. */
1946 Vgui_element_face = Fmake_face(Qgui_element,
1947 build_string("gui element face"), Qnil);
1949 /* Provide some last-resort fallbacks for gui-element face which
1950 mustn't default to default. */
1952 Lisp_Object fg_fb = Qnil, bg_fb = Qnil;
1954 #ifdef HAVE_X_WINDOWS
1955 fg_fb = acons(list1(Qx), build_string("black"), fg_fb);
1956 bg_fb = acons(list1(Qx), build_string("Gray80"), bg_fb);
1959 fg_fb = acons(list1(Qtty), Fvector(0, 0), fg_fb);
1960 bg_fb = acons(list1(Qtty), Fvector(0, 0), bg_fb);
1962 set_specifier_fallback(Fget
1963 (Vgui_element_face, Qforeground, Qnil),
1965 set_specifier_fallback(Fget
1966 (Vgui_element_face, Qbackground, Qnil),
1970 /* Now create the other faces that redisplay needs to refer to
1971 directly. We could create them in Lisp but it's simpler this
1972 way since we need to get them anyway. */
1974 /* modeline is gui element. */
1975 Vmodeline_face = Fmake_face(Qmodeline, build_string("modeline face"),
1978 set_specifier_fallback(Fget(Vmodeline_face, Qforeground, Qunbound),
1979 Fget(Vgui_element_face, Qforeground, Qunbound));
1980 set_specifier_fallback(Fget(Vmodeline_face, Qbackground, Qunbound),
1981 Fget(Vgui_element_face, Qbackground, Qunbound));
1982 set_specifier_fallback(Fget(Vmodeline_face, Qbackground_pixmap, Qnil),
1983 Fget(Vgui_element_face, Qbackground_pixmap,
1986 /* toolbar is another gui element */
1987 Vtoolbar_face = Fmake_face(Qtoolbar,
1988 build_string("toolbar face"), Qnil);
1989 set_specifier_fallback(Fget(Vtoolbar_face, Qforeground, Qunbound),
1990 Fget(Vgui_element_face, Qforeground, Qunbound));
1991 set_specifier_fallback(Fget(Vtoolbar_face, Qbackground, Qunbound),
1992 Fget(Vgui_element_face, Qbackground, Qunbound));
1993 set_specifier_fallback(Fget(Vtoolbar_face, Qbackground_pixmap, Qnil),
1994 Fget(Vgui_element_face, Qbackground_pixmap,
1997 /* vertical divider is another gui element */
1998 Vvertical_divider_face = Fmake_face(Qvertical_divider,
2000 ("vertical divider face"), Qnil);
2002 set_specifier_fallback(Fget
2003 (Vvertical_divider_face, Qforeground, Qunbound),
2004 Fget(Vgui_element_face, Qforeground, Qunbound));
2005 set_specifier_fallback(Fget
2006 (Vvertical_divider_face, Qbackground, Qunbound),
2007 Fget(Vgui_element_face, Qbackground, Qunbound));
2008 set_specifier_fallback(Fget
2009 (Vvertical_divider_face, Qbackground_pixmap,
2010 Qunbound), Fget(Vgui_element_face,
2011 Qbackground_pixmap, Qunbound));
2013 /* widget is another gui element */
2014 Vwidget_face = Fmake_face(Qwidget, build_string("widget face"), Qnil);
2015 set_specifier_fallback(Fget(Vwidget_face, Qfont, Qunbound),
2016 Fget(Vgui_element_face, Qfont, Qunbound));
2017 set_specifier_fallback(Fget(Vwidget_face, Qforeground, Qunbound),
2018 Fget(Vgui_element_face, Qforeground, Qunbound));
2019 set_specifier_fallback(Fget(Vwidget_face, Qbackground, Qunbound),
2020 Fget(Vgui_element_face, Qbackground, Qunbound));
2021 /* We don't want widgets to have a default background pixmap. */
2023 Vleft_margin_face = Fmake_face(Qleft_margin,
2024 build_string("left margin face"), Qnil);
2025 Vright_margin_face = Fmake_face(Qright_margin,
2026 build_string("right margin face"),
2028 Vtext_cursor_face = Fmake_face(Qtext_cursor,
2029 build_string("face for text cursor"),
2032 Fmake_face(Qpointer,
2034 ("face for foreground/background colors of mouse pointer"),