Mercurial > hg > xemacs-beta

comparison src/faces.c @ 0:376386a54a3c r19-14

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