Mercurial > hg > xemacs-beta
annotate src/faces.c @ 5157:1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
-------------------- ChangeLog entries follow: --------------------
lisp/ChangeLog addition:
2010-03-18 Ben Wing <ben@xemacs.org>
* diagnose.el (show-memory-usage):
Rewrite to take into account API changes in memory-usage functions.
src/ChangeLog addition:
2010-03-18 Ben Wing <ben@xemacs.org>
* alloc.c:
* alloc.c (disksave_object_finalization_1):
* alloc.c (lisp_object_storage_size):
* alloc.c (listu):
* alloc.c (listn):
* alloc.c (Fobject_memory_usage_stats):
* alloc.c (compute_memusage_stats_length):
* alloc.c (Fobject_memory_usage):
* alloc.c (Ftotal_object_memory_usage):
* alloc.c (malloced_storage_size):
* alloc.c (common_init_alloc_early):
* alloc.c (reinit_alloc_objects_early):
* alloc.c (reinit_alloc_early):
* alloc.c (init_alloc_once_early):
* alloc.c (syms_of_alloc):
* alloc.c (reinit_vars_of_alloc):
* buffer.c:
* buffer.c (struct buffer_stats):
* buffer.c (compute_buffer_text_usage):
* buffer.c (compute_buffer_usage):
* buffer.c (buffer_memory_usage):
* buffer.c (buffer_objects_create):
* buffer.c (syms_of_buffer):
* buffer.c (vars_of_buffer):
* console-impl.h (struct console_methods):
* dynarr.c (Dynarr_memory_usage):
* emacs.c (main_1):
* events.c (clear_event_resource):
* extents.c:
* extents.c (compute_buffer_extent_usage):
* extents.c (extent_objects_create):
* extents.h:
* faces.c:
* faces.c (compute_face_cachel_usage):
* faces.c (face_objects_create):
* faces.h:
* general-slots.h:
* glyphs.c:
* glyphs.c (compute_glyph_cachel_usage):
* glyphs.c (glyph_objects_create):
* glyphs.h:
* lisp.h:
* lisp.h (struct usage_stats):
* lrecord.h:
* lrecord.h (enum lrecord_type):
* lrecord.h (struct lrecord_implementation):
* lrecord.h (MC_ALLOC_CALL_FINALIZER_FOR_DISKSAVE):
* lrecord.h (DEFINE_DUMPABLE_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_SIZABLE_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_FROB_BLOCK_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_FROB_BLOCK_SIZABLE_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_INTERNAL_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_SIZABLE_INTERNAL_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_SIZABLE_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_FROB_BLOCK_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_FROB_BLOCK_SIZABLE_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_INTERNAL_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_SIZABLE_INTERNAL_LISP_OBJECT):
* lrecord.h (MAKE_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_MODULE_LISP_OBJECT):
* lrecord.h (DEFINE_DUMPABLE_MODULE_SIZABLE_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_MODULE_LISP_OBJECT):
* lrecord.h (DEFINE_NODUMP_MODULE_SIZABLE_LISP_OBJECT):
* lrecord.h (MAKE_MODULE_LISP_OBJECT):
* lrecord.h (INIT_LISP_OBJECT):
* lrecord.h (INIT_MODULE_LISP_OBJECT):
* lrecord.h (UNDEF_LISP_OBJECT):
* lrecord.h (UNDEF_MODULE_LISP_OBJECT):
* lrecord.h (DECLARE_LISP_OBJECT):
* lrecord.h (DECLARE_MODULE_API_LISP_OBJECT):
* lrecord.h (DECLARE_MODULE_LISP_OBJECT):
* lstream.c:
* lstream.c (syms_of_lstream):
* lstream.c (vars_of_lstream):
* marker.c:
* marker.c (compute_buffer_marker_usage):
* mc-alloc.c (mc_alloced_storage_size):
* mc-alloc.h:
* mule-charset.c:
* mule-charset.c (struct charset_stats):
* mule-charset.c (compute_charset_usage):
* mule-charset.c (charset_memory_usage):
* mule-charset.c (mule_charset_objects_create):
* mule-charset.c (syms_of_mule_charset):
* mule-charset.c (vars_of_mule_charset):
* redisplay.c:
* redisplay.c (compute_rune_dynarr_usage):
* redisplay.c (compute_display_block_dynarr_usage):
* redisplay.c (compute_glyph_block_dynarr_usage):
* redisplay.c (compute_display_line_dynarr_usage):
* redisplay.c (compute_line_start_cache_dynarr_usage):
* redisplay.h:
* scrollbar-gtk.c (gtk_compute_scrollbar_instance_usage):
* scrollbar-msw.c (mswindows_compute_scrollbar_instance_usage):
* scrollbar-x.c (x_compute_scrollbar_instance_usage):
* scrollbar.c (compute_scrollbar_instance_usage):
* scrollbar.h:
* symbols.c:
* symbols.c (reinit_symbol_objects_early):
* symbols.c (init_symbols_once_early):
* symbols.c (reinit_symbols_early):
* symbols.c (defsymbol_massage_name_1):
* symsinit.h:
* ui-gtk.c:
* ui-gtk.c (emacs_gtk_object_getprop):
* ui-gtk.c (emacs_gtk_object_putprop):
* ui-gtk.c (ui_gtk_objects_create):
* unicode.c (compute_from_unicode_table_size_1):
* unicode.c (compute_to_unicode_table_size_1):
* unicode.c (compute_from_unicode_table_size):
* unicode.c (compute_to_unicode_table_size):
* window.c:
* window.c (struct window_stats):
* window.c (compute_window_mirror_usage):
* window.c (compute_window_usage):
* window.c (window_memory_usage):
* window.c (window_objects_create):
* window.c (syms_of_window):
* window.c (vars_of_window):
* window.h:
Redo memory-usage mechanism, make it general; add way of dynamically
initializing Lisp object types -- OBJECT_HAS_METHOD(), similar to
CONSOLE_HAS_METHOD().
(1) Create OBJECT_HAS_METHOD(), OBJECT_HAS_PROPERTY() etc. for
specifying that a Lisp object type has a particular method or
property. Call such methods with OBJECT_METH, MAYBE_OBJECT_METH,
OBJECT_METH_OR_GIVEN; retrieve properties with OBJECT_PROPERTY.
Methods that formerly required a DEFINE_*GENERAL_LISP_OBJECT() to
specify them (getprop, putprop, remprop, plist, disksave) now
instead use the dynamic-method mechanism. The main benefit of
this is that new methods or properties can be added without
requiring that the declaration statements of all existing methods
be modified. We have to make the `struct lrecord_implementation'
non-const, but I don't think this should have any effect on speed --
the only possible method that's really speed-critical is the
mark method, and we already extract those out into a separate
(non-const) array for increased cache locality.
Object methods need to be reinitialized after pdump, so we put
them in separate functions such as face_objects_create(),
extent_objects_create() and call them appropriately from emacs.c
The only current object property (`memusage_stats_list') that
objects can specify is a Lisp object and gets staticpro()ed so it
only needs to be set during dump time, but because it references
symbols that might not exist in a syms_of_() function, we
initialize it in vars_of_(). There is also an object property
(`num_extra_memusage_stats') that is automatically initialized based
on `memusage_stats_list'; we do that in reinit_vars_of_alloc(),
which is called after all vars_of_() functions are called.
`disksaver' method was renamed `disksave' to correspond with the
name normally given to the function (e.g. disksave_lstream()).
(2) Generalize the memory-usage mechanism in `buffer-memory-usage',
`window-memory-usage', `charset-memory-usage' into an object-type-
specific mechanism called by a single function
`object-memory-usage'. (Former function `object-memory-usage'
renamed to `total-object-memory-usage'). Generalize the mechanism
of different "slices" so that we can have different "classes" of
memory described and different "slices" onto each class; `t'
separates classes, `nil' separates slices. Currently we have
three classes defined: the memory of an object itself,
non-Lisp-object memory associated with the object (e.g. arrays or
dynarrs stored as fields in the object), and Lisp-object memory
associated with the object (other internal Lisp objects stored in
the object). This isn't completely finished yet and we might need
to further separate the "other internal Lisp objects" class into
two classes.
The memory-usage mechanism uses a `struct usage_stats' (renamed
from `struct overhead_stats') to describe a malloc-view onto a set
of allocated memory (listing how much was requested and various
types of overhead) and a more general `struct generic_usage_stats'
(with a `struct usage_stats' in it) to hold all statistics about
object memory. `struct generic_usage_stats' contains an array of
32 Bytecounts, which are statistics of unspecified semantics. The
intention is that individual types declare a corresponding struct
(e.g. `struct window_stats') with the same structure but with
specific fields in place of the array, corresponding to specific
statistics. The number of such statistics is an object property
computed from the list of tags (Lisp symbols describing the
statistics) stored in `memusage_stats_list'. The idea here is to
allow particular object types to customize the number and
semantics of the statistics where completely avoiding consing.
This doesn't matter so much yet, but the intention is to have the
memory usage of all objects computed at the end of GC, at the same
time as other statistics are currently computed. The values for
all statistics for a single type would be added up to compute
aggregate values for all objects of a specific type. To make this
efficient, we can't allow any memory allocation at all.
(3) Create some additional functions for creating lists that
specify the elements directly as args rather than indirectly through
an array: listn() (number of args given), listu() (list terminated
by Qunbound).
(4) Delete a bit of remaining unused C window_config stuff, also
unused lrecord_type_popup_data.
| author | Ben Wing <ben@xemacs.org> |
|---|---|
| date | Thu, 18 Mar 2010 10:50:06 -0500 |
| parents | 7be849cb8828 |
| children | 97eb4942aec8 |
| rev | line source |
|---|---|
| 428 | 1 /* "Face" primitives |
| 2 Copyright (C) 1994 Free Software Foundation, Inc. | |
| 3 Copyright (C) 1995 Board of Trustees, University of Illinois. | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
4 Copyright (C) 1995, 1996, 2001, 2002, 2005, 2010 Ben Wing. |
| 428 | 5 Copyright (C) 1995 Sun Microsystems, Inc. |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
6 Copyright (C) 2010 Didier Verna |
| 428 | 7 |
| 8 This file is part of XEmacs. | |
| 9 | |
| 10 XEmacs is free software; you can redistribute it and/or modify it | |
| 11 under the terms of the GNU General Public License as published by the | |
| 12 Free Software Foundation; either version 2, or (at your option) any | |
| 13 later version. | |
| 14 | |
| 15 XEmacs is distributed in the hope that it will be useful, but WITHOUT | |
| 16 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
| 17 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
| 18 for more details. | |
| 19 | |
| 20 You should have received a copy of the GNU General Public License | |
| 21 along with XEmacs; see the file COPYING. If not, write to | |
| 22 the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
| 23 Boston, MA 02111-1307, USA. */ | |
| 24 | |
| 25 /* Synched up with: Not in FSF. */ | |
| 26 | |
| 27 /* Written by Chuck Thompson and Ben Wing, | |
| 28 based loosely on old face code by Jamie Zawinski. */ | |
| 29 | |
| 30 #include <config.h> | |
| 31 #include "lisp.h" | |
| 32 | |
| 33 #include "buffer.h" | |
| 872 | 34 #include "device-impl.h" |
| 428 | 35 #include "elhash.h" |
| 872 | 36 #include "extents-impl.h" /* for extent_face */ |
| 428 | 37 #include "faces.h" |
| 872 | 38 #include "frame-impl.h" |
| 428 | 39 #include "glyphs.h" |
| 872 | 40 #include "objects-impl.h" |
| 428 | 41 #include "specifier.h" |
| 42 #include "window.h" | |
| 43 | |
| 44 Lisp_Object Qfacep; | |
| 45 Lisp_Object Qforeground, Qbackground, Qdisplay_table; | |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
46 Lisp_Object Qbackground_pixmap, Qbackground_placement, Qunderline, Qdim; |
| 428 | 47 Lisp_Object Qblinking, Qstrikethru; |
| 48 | |
| 49 Lisp_Object Qinit_face_from_resources; | |
| 50 Lisp_Object Qinit_frame_faces; | |
| 51 Lisp_Object Qinit_device_faces; | |
| 52 Lisp_Object Qinit_global_faces; | |
| 53 | |
| 54 /* These faces are used directly internally. We use these variables | |
| 55 to be able to reference them directly and save the overhead of | |
| 56 calling Ffind_face. */ | |
| 57 Lisp_Object Vdefault_face, Vmodeline_face, Vgui_element_face; | |
| 58 Lisp_Object Vleft_margin_face, Vright_margin_face, Vtext_cursor_face; | |
| 59 Lisp_Object Vpointer_face, Vvertical_divider_face, Vtoolbar_face, Vwidget_face; | |
| 60 | |
| 440 | 61 /* Qdefault, Qhighlight, Qleft_margin, Qright_margin defined in general.c */ |
| 62 Lisp_Object Qmodeline, Qgui_element, Qtext_cursor, Qvertical_divider; | |
| 428 | 63 |
| 2867 | 64 Lisp_Object Qface_alias, Qcyclic_face_alias; |
| 2865 | 65 |
| 428 | 66 /* In the old implementation Vface_list was a list of the face names, |
| 67 not the faces themselves. We now distinguish between permanent and | |
| 68 temporary faces. Permanent faces are kept in a regular hash table, | |
| 69 temporary faces in a weak hash table. */ | |
| 70 Lisp_Object Vpermanent_faces_cache; | |
| 71 Lisp_Object Vtemporary_faces_cache; | |
| 72 | |
| 73 Lisp_Object Vbuilt_in_face_specifiers; | |
| 74 | |
| 75 | |
| 3659 | 76 #ifdef DEBUG_XEMACS |
| 77 Fixnum debug_x_faces; | |
| 78 #endif | |
| 79 | |
| 4187 | 80 #if defined(__STDC_VERSION__) && (__STDC_VERSION__ >= 199901) |
| 3659 | 81 |
| 82 #ifdef DEBUG_XEMACS | |
| 83 # define DEBUG_FACES(FORMAT, ...) \ | |
| 84 do { if (debug_x_faces) stderr_out(FORMAT, __VA_ARGS__); } while (0) | |
| 85 #else /* DEBUG_XEMACS */ | |
| 86 # define DEBUG_FACES(format, ...) | |
| 87 #endif /* DEBUG_XEMACS */ | |
| 88 | |
| 89 #elif defined(__GNUC__) | |
| 90 | |
| 91 #ifdef DEBUG_XEMACS | |
| 92 # define DEBUG_FACES(format, args...) \ | |
| 93 do { if (debug_x_faces) stderr_out(format, args ); } while (0) | |
| 94 #else /* DEBUG_XEMACS */ | |
| 95 # define DEBUG_FACES(format, args...) | |
| 96 #endif /* DEBUG_XEMACS */ | |
| 97 | |
| 98 #else /* defined(__STDC_VERSION__) [...] */ | |
| 99 # define DEBUG_FACES (void) | |
| 100 #endif | |
| 428 | 101 |
| 102 static Lisp_Object | |
| 103 mark_face (Lisp_Object obj) | |
| 104 { | |
| 440 | 105 Lisp_Face *face = XFACE (obj); |
| 428 | 106 |
| 107 mark_object (face->name); | |
| 108 mark_object (face->doc_string); | |
| 109 | |
| 110 mark_object (face->foreground); | |
| 111 mark_object (face->background); | |
| 112 mark_object (face->font); | |
| 113 mark_object (face->display_table); | |
| 114 mark_object (face->background_pixmap); | |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
115 mark_object (face->background_placement); |
| 428 | 116 mark_object (face->underline); |
| 117 mark_object (face->strikethru); | |
| 118 mark_object (face->highlight); | |
| 119 mark_object (face->dim); | |
| 120 mark_object (face->blinking); | |
| 121 mark_object (face->reverse); | |
| 122 | |
| 123 mark_object (face->charsets_warned_about); | |
| 124 | |
| 125 return face->plist; | |
| 126 } | |
| 127 | |
| 128 static void | |
| 2286 | 129 print_face (Lisp_Object obj, Lisp_Object printcharfun, int UNUSED (escapeflag)) |
| 428 | 130 { |
| 440 | 131 Lisp_Face *face = XFACE (obj); |
| 428 | 132 |
| 133 if (print_readably) | |
| 134 { | |
| 800 | 135 write_fmt_string_lisp (printcharfun, "#s(face name %S)", 1, face->name); |
| 428 | 136 } |
| 137 else | |
| 138 { | |
| 800 | 139 write_fmt_string_lisp (printcharfun, "#<face %S", 1, face->name); |
| 428 | 140 if (!NILP (face->doc_string)) |
| 800 | 141 write_fmt_string_lisp (printcharfun, " %S", 1, face->doc_string); |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4862
diff
changeset
|
142 write_ascstring (printcharfun, ">"); |
| 428 | 143 } |
| 144 } | |
| 145 | |
| 146 /* Faces are equal if all of their display attributes are equal. We | |
| 147 don't compare names or doc-strings, because that would make equal | |
| 148 be eq. | |
| 149 | |
| 150 This isn't concerned with "unspecified" attributes, that's what | |
| 151 #'face-differs-from-default-p is for. */ | |
| 152 static int | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4862
diff
changeset
|
153 face_equal (Lisp_Object obj1, Lisp_Object obj2, int depth, |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4862
diff
changeset
|
154 int UNUSED (foldcase)) |
| 428 | 155 { |
| 440 | 156 Lisp_Face *f1 = XFACE (obj1); |
| 157 Lisp_Face *f2 = XFACE (obj2); | |
| 428 | 158 |
| 159 depth++; | |
| 160 | |
| 161 return | |
| 162 (internal_equal (f1->foreground, f2->foreground, depth) && | |
| 163 internal_equal (f1->background, f2->background, depth) && | |
| 164 internal_equal (f1->font, f2->font, depth) && | |
| 165 internal_equal (f1->display_table, f2->display_table, depth) && | |
| 166 internal_equal (f1->background_pixmap, f2->background_pixmap, depth) && | |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
167 internal_equal (f1->background_placement, |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
168 f2->background_placement, |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
169 depth) && |
| 428 | 170 internal_equal (f1->underline, f2->underline, depth) && |
| 171 internal_equal (f1->strikethru, f2->strikethru, depth) && | |
| 172 internal_equal (f1->highlight, f2->highlight, depth) && | |
| 173 internal_equal (f1->dim, f2->dim, depth) && | |
| 174 internal_equal (f1->blinking, f2->blinking, depth) && | |
| 175 internal_equal (f1->reverse, f2->reverse, depth) && | |
| 176 | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4862
diff
changeset
|
177 ! plists_differ (f1->plist, f2->plist, 0, 0, depth + 1, 0)); |
| 428 | 178 } |
| 179 | |
| 665 | 180 static Hashcode |
| 428 | 181 face_hash (Lisp_Object obj, int depth) |
| 182 { | |
| 440 | 183 Lisp_Face *f = XFACE (obj); |
| 428 | 184 |
| 185 depth++; | |
| 186 | |
| 187 /* No need to hash all of the elements; that would take too long. | |
| 188 Just hash the most common ones. */ | |
| 189 return HASH3 (internal_hash (f->foreground, depth), | |
| 190 internal_hash (f->background, depth), | |
| 191 internal_hash (f->font, depth)); | |
| 192 } | |
| 193 | |
| 194 static Lisp_Object | |
| 195 face_getprop (Lisp_Object obj, Lisp_Object prop) | |
| 196 { | |
| 440 | 197 Lisp_Face *f = XFACE (obj); |
| 428 | 198 |
| 199 return | |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
200 (EQ (prop, Qforeground) ? f->foreground : |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
201 EQ (prop, Qbackground) ? f->background : |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
202 EQ (prop, Qfont) ? f->font : |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
203 EQ (prop, Qdisplay_table) ? f->display_table : |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
204 EQ (prop, Qbackground_pixmap) ? f->background_pixmap : |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
205 EQ (prop, Qbackground_placement) ? f->background_placement : |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
206 EQ (prop, Qunderline) ? f->underline : |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
207 EQ (prop, Qstrikethru) ? f->strikethru : |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
208 EQ (prop, Qhighlight) ? f->highlight : |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
209 EQ (prop, Qdim) ? f->dim : |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
210 EQ (prop, Qblinking) ? f->blinking : |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
211 EQ (prop, Qreverse) ? f->reverse : |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
212 EQ (prop, Qdoc_string) ? f->doc_string : |
| 428 | 213 external_plist_get (&f->plist, prop, 0, ERROR_ME)); |
| 214 } | |
| 215 | |
| 216 static int | |
| 217 face_putprop (Lisp_Object obj, Lisp_Object prop, Lisp_Object value) | |
| 218 { | |
| 440 | 219 Lisp_Face *f = XFACE (obj); |
| 428 | 220 |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
221 if (EQ (prop, Qforeground) || |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
222 EQ (prop, Qbackground) || |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
223 EQ (prop, Qfont) || |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
224 EQ (prop, Qdisplay_table) || |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
225 EQ (prop, Qbackground_pixmap) || |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
226 EQ (prop, Qbackground_placement) || |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
227 EQ (prop, Qunderline) || |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
228 EQ (prop, Qstrikethru) || |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
229 EQ (prop, Qhighlight) || |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
230 EQ (prop, Qdim) || |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
231 EQ (prop, Qblinking) || |
| 428 | 232 EQ (prop, Qreverse)) |
| 233 return 0; | |
| 234 | |
| 235 if (EQ (prop, Qdoc_string)) | |
| 236 { | |
| 237 if (!NILP (value)) | |
| 238 CHECK_STRING (value); | |
| 239 f->doc_string = value; | |
| 240 return 1; | |
| 241 } | |
| 242 | |
| 243 external_plist_put (&f->plist, prop, value, 0, ERROR_ME); | |
| 244 return 1; | |
| 245 } | |
| 246 | |
| 247 static int | |
| 248 face_remprop (Lisp_Object obj, Lisp_Object prop) | |
| 249 { | |
| 440 | 250 Lisp_Face *f = XFACE (obj); |
| 428 | 251 |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
252 if (EQ (prop, Qforeground) || |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
253 EQ (prop, Qbackground) || |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
254 EQ (prop, Qfont) || |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
255 EQ (prop, Qdisplay_table) || |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
256 EQ (prop, Qbackground_pixmap) || |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
257 EQ (prop, Qbackground_placement) || |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
258 EQ (prop, Qunderline) || |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
259 EQ (prop, Qstrikethru) || |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
260 EQ (prop, Qhighlight) || |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
261 EQ (prop, Qdim) || |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
262 EQ (prop, Qblinking) || |
| 428 | 263 EQ (prop, Qreverse)) |
| 264 return -1; | |
| 265 | |
| 266 if (EQ (prop, Qdoc_string)) | |
| 267 { | |
| 268 f->doc_string = Qnil; | |
| 269 return 1; | |
| 270 } | |
| 271 | |
| 272 return external_remprop (&f->plist, prop, 0, ERROR_ME); | |
| 273 } | |
| 274 | |
| 275 static Lisp_Object | |
| 276 face_plist (Lisp_Object obj) | |
| 277 { | |
| 440 | 278 Lisp_Face *face = XFACE (obj); |
| 428 | 279 Lisp_Object result = face->plist; |
| 280 | |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
281 result = cons3 (Qreverse, face->reverse, result); |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
282 result = cons3 (Qblinking, face->blinking, result); |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
283 result = cons3 (Qdim, face->dim, result); |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
284 result = cons3 (Qhighlight, face->highlight, result); |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
285 result = cons3 (Qstrikethru, face->strikethru, result); |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
286 result = cons3 (Qunderline, face->underline, result); |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
287 result = cons3 (Qbackground_placement, face->background_placement, result); |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
288 result = cons3 (Qbackground_pixmap, face->background_pixmap, result); |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
289 result = cons3 (Qdisplay_table, face->display_table, result); |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
290 result = cons3 (Qfont, face->font, result); |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
291 result = cons3 (Qbackground, face->background, result); |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
292 result = cons3 (Qforeground, face->foreground, result); |
| 428 | 293 |
| 294 return result; | |
| 295 } | |
| 296 | |
| 1204 | 297 static const struct memory_description face_description[] = { |
| 440 | 298 { XD_LISP_OBJECT, offsetof (Lisp_Face, name) }, |
| 299 { XD_LISP_OBJECT, offsetof (Lisp_Face, doc_string) }, | |
| 300 { XD_LISP_OBJECT, offsetof (Lisp_Face, foreground) }, | |
| 301 { XD_LISP_OBJECT, offsetof (Lisp_Face, background) }, | |
| 302 { XD_LISP_OBJECT, offsetof (Lisp_Face, font) }, | |
| 303 { XD_LISP_OBJECT, offsetof (Lisp_Face, display_table) }, | |
| 304 { XD_LISP_OBJECT, offsetof (Lisp_Face, background_pixmap) }, | |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
305 { XD_LISP_OBJECT, offsetof (Lisp_Face, background_placement) }, |
| 440 | 306 { XD_LISP_OBJECT, offsetof (Lisp_Face, underline) }, |
| 307 { XD_LISP_OBJECT, offsetof (Lisp_Face, strikethru) }, | |
| 308 { XD_LISP_OBJECT, offsetof (Lisp_Face, highlight) }, | |
| 309 { XD_LISP_OBJECT, offsetof (Lisp_Face, dim) }, | |
| 310 { XD_LISP_OBJECT, offsetof (Lisp_Face, blinking) }, | |
| 311 { XD_LISP_OBJECT, offsetof (Lisp_Face, reverse) }, | |
| 312 { XD_LISP_OBJECT, offsetof (Lisp_Face, plist) }, | |
| 313 { XD_LISP_OBJECT, offsetof (Lisp_Face, charsets_warned_about) }, | |
| 428 | 314 { XD_END } |
| 315 }; | |
| 316 | |
|
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5128
diff
changeset
|
317 DEFINE_DUMPABLE_LISP_OBJECT ("face", face, |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5128
diff
changeset
|
318 mark_face, print_face, 0, face_equal, |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5128
diff
changeset
|
319 face_hash, face_description, |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5128
diff
changeset
|
320 Lisp_Face); |
| 428 | 321 |
| 322 /************************************************************************/ | |
| 323 /* face read syntax */ | |
| 324 /************************************************************************/ | |
| 325 | |
| 326 static int | |
| 2286 | 327 face_name_validate (Lisp_Object UNUSED (keyword), Lisp_Object value, |
| 578 | 328 Error_Behavior errb) |
| 428 | 329 { |
| 330 if (ERRB_EQ (errb, ERROR_ME)) | |
| 331 { | |
| 332 CHECK_SYMBOL (value); | |
| 333 return 1; | |
| 334 } | |
| 335 | |
| 336 return SYMBOLP (value); | |
| 337 } | |
| 338 | |
| 339 static int | |
| 578 | 340 face_validate (Lisp_Object data, Error_Behavior errb) |
| 428 | 341 { |
| 342 int name_seen = 0; | |
| 343 Lisp_Object valw = Qnil; | |
| 344 | |
| 345 data = Fcdr (data); /* skip over Qface */ | |
| 346 while (!NILP (data)) | |
| 347 { | |
| 348 Lisp_Object keyw = Fcar (data); | |
| 349 | |
| 350 data = Fcdr (data); | |
| 351 valw = Fcar (data); | |
| 352 data = Fcdr (data); | |
| 353 if (EQ (keyw, Qname)) | |
| 354 name_seen = 1; | |
| 355 else | |
| 2500 | 356 ABORT (); |
| 428 | 357 } |
| 358 | |
| 359 if (!name_seen) | |
| 360 { | |
| 563 | 361 maybe_sferror ("No face name given", Qunbound, Qface, errb); |
| 428 | 362 return 0; |
| 363 } | |
| 364 | |
| 365 if (NILP (Ffind_face (valw))) | |
| 366 { | |
| 563 | 367 maybe_invalid_argument ("No such face", valw, Qface, errb); |
| 428 | 368 return 0; |
| 369 } | |
| 370 | |
| 371 return 1; | |
| 372 } | |
| 373 | |
| 374 static Lisp_Object | |
| 375 face_instantiate (Lisp_Object data) | |
| 376 { | |
| 377 return Fget_face (Fcar (Fcdr (data))); | |
| 378 } | |
| 379 | |
| 380 | |
| 381 /**************************************************************************** | |
| 382 * utility functions * | |
| 383 ****************************************************************************/ | |
| 384 | |
| 385 static void | |
| 440 | 386 reset_face (Lisp_Face *f) |
| 428 | 387 { |
| 388 f->name = Qnil; | |
| 389 f->doc_string = Qnil; | |
| 390 f->dirty = 0; | |
| 391 f->foreground = Qnil; | |
| 392 f->background = Qnil; | |
| 393 f->font = Qnil; | |
| 394 f->display_table = Qnil; | |
| 395 f->background_pixmap = Qnil; | |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
396 f->background_placement = Qnil; |
| 428 | 397 f->underline = Qnil; |
| 398 f->strikethru = Qnil; | |
| 399 f->highlight = Qnil; | |
| 400 f->dim = Qnil; | |
| 401 f->blinking = Qnil; | |
| 402 f->reverse = Qnil; | |
| 403 f->plist = Qnil; | |
| 404 f->charsets_warned_about = Qnil; | |
| 405 } | |
| 406 | |
| 440 | 407 static Lisp_Face * |
| 428 | 408 allocate_face (void) |
| 409 { | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5126
diff
changeset
|
410 Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (face); |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
411 Lisp_Face *result = XFACE (obj); |
| 428 | 412 |
| 413 reset_face (result); | |
| 414 return result; | |
| 415 } | |
| 416 | |
| 417 | |
| 418 /* We store the faces in hash tables with the names as the key and the | |
| 419 actual face object as the value. Occasionally we need to use them | |
| 420 in a list format. These routines provide us with that. */ | |
| 421 struct face_list_closure | |
| 422 { | |
| 423 Lisp_Object *face_list; | |
| 424 }; | |
| 425 | |
| 426 static int | |
| 2286 | 427 add_face_to_list_mapper (Lisp_Object UNUSED (key), Lisp_Object value, |
| 428 | 428 void *face_list_closure) |
| 429 { | |
| 430 /* This function can GC */ | |
| 431 struct face_list_closure *fcl = | |
| 432 (struct face_list_closure *) face_list_closure; | |
| 433 | |
| 434 *(fcl->face_list) = Fcons (XFACE (value)->name, (*fcl->face_list)); | |
| 435 return 0; | |
| 436 } | |
| 437 | |
| 438 static Lisp_Object | |
| 439 faces_list_internal (Lisp_Object list) | |
| 440 { | |
| 441 Lisp_Object face_list = Qnil; | |
| 442 struct gcpro gcpro1; | |
| 443 struct face_list_closure face_list_closure; | |
| 444 | |
| 445 GCPRO1 (face_list); | |
| 446 face_list_closure.face_list = &face_list; | |
| 447 elisp_maphash (add_face_to_list_mapper, list, &face_list_closure); | |
| 448 UNGCPRO; | |
| 449 | |
| 450 return face_list; | |
| 451 } | |
| 452 | |
| 453 static Lisp_Object | |
| 454 permanent_faces_list (void) | |
| 455 { | |
| 456 return faces_list_internal (Vpermanent_faces_cache); | |
| 457 } | |
| 458 | |
| 459 static Lisp_Object | |
| 460 temporary_faces_list (void) | |
| 461 { | |
| 462 return faces_list_internal (Vtemporary_faces_cache); | |
| 463 } | |
| 464 | |
| 465 | |
| 466 static int | |
| 2286 | 467 mark_face_as_clean_mapper (Lisp_Object UNUSED (key), Lisp_Object value, |
| 428 | 468 void *flag_closure) |
| 469 { | |
| 470 /* This function can GC */ | |
| 471 int *flag = (int *) flag_closure; | |
| 472 XFACE (value)->dirty = *flag; | |
| 473 return 0; | |
| 474 } | |
| 475 | |
| 476 static void | |
| 477 mark_all_faces_internal (int flag) | |
| 478 { | |
| 479 elisp_maphash (mark_face_as_clean_mapper, Vpermanent_faces_cache, &flag); | |
| 480 elisp_maphash (mark_face_as_clean_mapper, Vtemporary_faces_cache, &flag); | |
| 481 } | |
| 482 | |
| 483 void | |
| 484 mark_all_faces_as_clean (void) | |
| 485 { | |
| 486 mark_all_faces_internal (0); | |
| 487 } | |
| 488 | |
| 489 /* Currently unused (see the comment in face_property_was_changed()). */ | |
| 490 #if 0 | |
| 491 /* #### OBSOLETE ME, PLEASE. Maybe. Maybe this is just as good as | |
| 492 any other solution. */ | |
| 493 struct face_inheritance_closure | |
| 494 { | |
| 495 Lisp_Object face; | |
| 496 Lisp_Object property; | |
| 497 }; | |
| 498 | |
| 499 static void | |
| 500 update_inheritance_mapper_internal (Lisp_Object cur_face, | |
| 501 Lisp_Object inh_face, | |
| 502 Lisp_Object property) | |
| 503 { | |
| 504 /* #### fix this function */ | |
| 505 Lisp_Object elt = Qnil; | |
| 506 struct gcpro gcpro1; | |
| 507 | |
| 508 GCPRO1 (elt); | |
| 509 | |
| 510 for (elt = FACE_PROPERTY_SPEC_LIST (cur_face, property, Qall); | |
| 511 !NILP (elt); | |
| 512 elt = XCDR (elt)) | |
| 513 { | |
| 514 Lisp_Object values = XCDR (XCAR (elt)); | |
| 515 | |
| 516 for (; !NILP (values); values = XCDR (values)) | |
| 517 { | |
| 518 Lisp_Object value = XCDR (XCAR (values)); | |
| 519 if (VECTORP (value) && XVECTOR_LENGTH (value)) | |
| 520 { | |
| 521 if (EQ (Ffind_face (XVECTOR_DATA (value)[0]), inh_face)) | |
| 522 Fset_specifier_dirty_flag | |
| 523 (FACE_PROPERTY_SPECIFIER (inh_face, property)); | |
| 524 } | |
| 525 } | |
| 526 } | |
| 527 | |
| 528 UNGCPRO; | |
| 529 } | |
| 530 | |
| 531 static int | |
| 442 | 532 update_face_inheritance_mapper (const void *hash_key, void *hash_contents, |
| 428 | 533 void *face_inheritance_closure) |
| 534 { | |
| 535 Lisp_Object key, contents; | |
| 536 struct face_inheritance_closure *fcl = | |
| 537 (struct face_inheritance_closure *) face_inheritance_closure; | |
| 538 | |
| 5013 | 539 key = GET_LISP_FROM_VOID (hash_key); |
| 540 contents = GET_LISP_FROM_VOID (hash_contents); | |
| 428 | 541 |
| 542 if (EQ (fcl->property, Qfont)) | |
| 543 { | |
| 544 update_inheritance_mapper_internal (contents, fcl->face, Qfont); | |
| 545 } | |
| 546 else if (EQ (fcl->property, Qforeground) || | |
| 547 EQ (fcl->property, Qbackground)) | |
| 548 { | |
| 549 update_inheritance_mapper_internal (contents, fcl->face, Qforeground); | |
| 550 update_inheritance_mapper_internal (contents, fcl->face, Qbackground); | |
| 551 } | |
| 552 else if (EQ (fcl->property, Qunderline) || | |
| 553 EQ (fcl->property, Qstrikethru) || | |
| 554 EQ (fcl->property, Qhighlight) || | |
| 555 EQ (fcl->property, Qdim) || | |
| 556 EQ (fcl->property, Qblinking) || | |
| 557 EQ (fcl->property, Qreverse)) | |
| 558 { | |
| 559 update_inheritance_mapper_internal (contents, fcl->face, Qunderline); | |
| 560 update_inheritance_mapper_internal (contents, fcl->face, Qstrikethru); | |
| 561 update_inheritance_mapper_internal (contents, fcl->face, Qhighlight); | |
| 562 update_inheritance_mapper_internal (contents, fcl->face, Qdim); | |
| 563 update_inheritance_mapper_internal (contents, fcl->face, Qblinking); | |
| 564 update_inheritance_mapper_internal (contents, fcl->face, Qreverse); | |
| 565 } | |
| 566 return 0; | |
| 567 } | |
| 568 | |
| 569 static void | |
| 570 update_faces_inheritance (Lisp_Object face, Lisp_Object property) | |
| 571 { | |
| 572 struct face_inheritance_closure face_inheritance_closure; | |
| 573 struct gcpro gcpro1, gcpro2; | |
| 574 | |
| 575 GCPRO2 (face, property); | |
| 576 face_inheritance_closure.face = face; | |
| 577 face_inheritance_closure.property = property; | |
| 578 | |
| 579 elisp_maphash (update_face_inheritance_mapper, Vpermanent_faces_cache, | |
| 580 &face_inheritance_closure); | |
| 581 elisp_maphash (update_face_inheritance_mapper, Vtemporary_faces_cache, | |
| 582 &face_inheritance_closure); | |
| 583 | |
| 584 UNGCPRO; | |
| 585 } | |
| 586 #endif /* 0 */ | |
| 587 | |
| 588 Lisp_Object | |
| 589 face_property_matching_instance (Lisp_Object face, Lisp_Object property, | |
| 590 Lisp_Object charset, Lisp_Object domain, | |
| 578 | 591 Error_Behavior errb, int no_fallback, |
| 3659 | 592 Lisp_Object depth, |
| 593 enum font_specifier_matchspec_stages stage) | |
| 428 | 594 { |
| 771 | 595 Lisp_Object retval; |
| 872 | 596 Lisp_Object matchspec = Qunbound; |
| 597 struct gcpro gcpro1; | |
| 771 | 598 |
| 872 | 599 if (!NILP (charset)) |
| 4187 | 600 matchspec = noseeum_cons (charset, |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
601 stage == STAGE_INITIAL ? Qinitial : Qfinal); |
| 3659 | 602 |
| 872 | 603 GCPRO1 (matchspec); |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
604 /* This call to specifier_instance_no_quit(), will end up calling |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
605 font_instantiate() if the property in a question is a font (currently, |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
606 this means EQ (property, Qfont), because only the face property named |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
607 `font' contains a font object). See the comments there. */ |
| 872 | 608 retval = specifier_instance_no_quit (Fget (face, property, Qnil), matchspec, |
| 771 | 609 domain, errb, no_fallback, depth); |
| 872 | 610 UNGCPRO; |
| 611 if (CONSP (matchspec)) | |
| 612 free_cons (matchspec); | |
| 428 | 613 |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
614 if (UNBOUNDP (retval) && !no_fallback && STAGE_FINAL == stage) |
| 428 | 615 { |
| 616 if (EQ (property, Qfont)) | |
| 617 { | |
| 618 if (NILP (memq_no_quit (charset, | |
| 619 XFACE (face)->charsets_warned_about))) | |
| 620 { | |
| 793 | 621 if (!UNBOUNDP (charset)) |
| 428 | 622 warn_when_safe |
| 793 | 623 (Qfont, Qnotice, |
| 624 "Unable to instantiate font for charset %s, face %s", | |
| 625 XSTRING_DATA (symbol_name | |
| 626 (XSYMBOL (XCHARSET_NAME (charset)))), | |
| 627 XSTRING_DATA (symbol_name | |
| 628 (XSYMBOL (XFACE (face)->name)))); | |
| 428 | 629 XFACE (face)->charsets_warned_about = |
| 630 Fcons (charset, XFACE (face)->charsets_warned_about); | |
| 631 } | |
| 632 retval = Vthe_null_font_instance; | |
| 633 } | |
| 634 } | |
| 635 | |
| 636 return retval; | |
| 637 } | |
| 638 | |
| 639 | |
| 640 DEFUN ("facep", Ffacep, 1, 1, 0, /* | |
| 444 | 641 Return t if OBJECT is a face. |
| 428 | 642 */ |
| 643 (object)) | |
| 644 { | |
| 645 return FACEP (object) ? Qt : Qnil; | |
| 646 } | |
| 647 | |
| 648 DEFUN ("find-face", Ffind_face, 1, 1, 0, /* | |
| 649 Retrieve the face of the given name. | |
| 650 If FACE-OR-NAME is a face object, it is simply returned. | |
| 651 Otherwise, FACE-OR-NAME should be a symbol. If there is no such face, | |
| 652 nil is returned. Otherwise the associated face object is returned. | |
| 653 */ | |
| 654 (face_or_name)) | |
| 655 { | |
| 656 Lisp_Object retval; | |
| 2865 | 657 Lisp_Object face_name; |
| 658 Lisp_Object face_alias; | |
| 659 int i; | |
| 428 | 660 |
| 661 if (FACEP (face_or_name)) | |
| 662 return face_or_name; | |
| 2865 | 663 |
| 664 face_name = face_or_name; | |
| 665 CHECK_SYMBOL (face_name); | |
| 666 | |
| 2867 | 667 # define FACE_ALIAS_MAX_DEPTH 32 |
| 2865 | 668 |
| 669 i = 0; | |
| 670 while (! NILP ((face_alias = Fget (face_name, Qface_alias, Qnil))) | |
| 2867 | 671 && i < FACE_ALIAS_MAX_DEPTH) |
| 2865 | 672 { |
| 673 face_name = face_alias; | |
| 674 CHECK_SYMBOL (face_alias); | |
| 675 i += 1; | |
| 676 } | |
| 677 | |
| 678 /* #### This test actually makes the aliasing max depth to 30, which is more | |
| 679 #### than enough IMO. -- dvl */ | |
| 2867 | 680 if (i == FACE_ALIAS_MAX_DEPTH) |
| 681 signal_error (Qcyclic_face_alias, | |
| 2865 | 682 "Max face aliasing depth reached", |
| 683 face_name); | |
| 684 | |
| 2867 | 685 # undef FACE_ALIAS_MAX_DEPTH |
| 428 | 686 |
| 687 /* Check if the name represents a permanent face. */ | |
| 2865 | 688 retval = Fgethash (face_name, Vpermanent_faces_cache, Qnil); |
| 428 | 689 if (!NILP (retval)) |
| 690 return retval; | |
| 691 | |
| 692 /* Check if the name represents a temporary face. */ | |
| 2865 | 693 return Fgethash (face_name, Vtemporary_faces_cache, Qnil); |
| 428 | 694 } |
| 695 | |
| 696 DEFUN ("get-face", Fget_face, 1, 1, 0, /* | |
| 697 Retrieve the face of the given name. | |
| 698 Same as `find-face' except an error is signalled if there is no such | |
| 699 face instead of returning nil. | |
| 700 */ | |
| 701 (name)) | |
| 702 { | |
| 703 Lisp_Object face = Ffind_face (name); | |
| 704 | |
| 705 if (NILP (face)) | |
| 563 | 706 invalid_argument ("No such face", name); |
| 428 | 707 return face; |
| 708 } | |
| 709 | |
| 710 DEFUN ("face-name", Fface_name, 1, 1, 0, /* | |
| 711 Return the name of the given face. | |
| 712 */ | |
| 713 (face)) | |
| 714 { | |
| 715 return XFACE (Fget_face (face))->name; | |
| 716 } | |
| 717 | |
| 718 DEFUN ("built-in-face-specifiers", Fbuilt_in_face_specifiers, 0, 0, 0, /* | |
| 719 Return a list of all built-in face specifier properties. | |
|
4534
f32c7f843961
#'built-in-face-specifiers; document that we're returning a copy.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4532
diff
changeset
|
720 |
|
f32c7f843961
#'built-in-face-specifiers; document that we're returning a copy.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4532
diff
changeset
|
721 This is a copy; there is no way to modify XEmacs' idea of the built-in face |
|
f32c7f843961
#'built-in-face-specifiers; document that we're returning a copy.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4532
diff
changeset
|
722 specifier properties from Lisp. |
| 428 | 723 */ |
| 724 ()) | |
| 725 { | |
|
4532
16906fefc8df
Return a list copy in #'built-in-face-specifiers, pre-empting modification.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4210
diff
changeset
|
726 return Fcopy_list(Vbuilt_in_face_specifiers); |
| 428 | 727 } |
| 728 | |
| 729 /* These values are retrieved so often that we make a special | |
| 730 function. | |
| 731 */ | |
| 732 | |
| 733 void | |
| 734 default_face_font_info (Lisp_Object domain, int *ascent, int *descent, | |
|
5047
07dcc7000bbf
put width before height consistently, fix a real bug found in the process
Ben Wing <ben@xemacs.org>
parents:
5043
diff
changeset
|
735 int *width, int *height, int *proportional_p) |
| 428 | 736 { |
| 737 Lisp_Object font_instance; | |
| 3707 | 738 struct face_cachel *cachel; |
| 739 struct window *w = NULL; | |
| 428 | 740 |
| 741 if (noninteractive) | |
| 742 { | |
| 743 if (ascent) | |
| 4187 | 744 *ascent = 1; |
| 428 | 745 if (descent) |
| 4187 | 746 *descent = 0; |
| 428 | 747 if (height) |
| 4187 | 748 *height = 1; |
| 428 | 749 if (width) |
| 4187 | 750 *width = 1; |
| 428 | 751 if (proportional_p) |
| 4187 | 752 *proportional_p = 0; |
| 428 | 753 return; |
| 754 } | |
| 755 | |
| 3707 | 756 /* We use ASCII here. This is reasonable because the people calling this |
| 757 function are using the resulting values to come up with overall sizes | |
| 4187 | 758 for windows and frames. |
| 3707 | 759 |
| 760 It's possible for this function to get called when the face cachels | |
| 761 have not been initialized--put a call to debug-print in | |
| 762 init-locale-at-early-startup to see it happen. */ | |
| 763 | |
| 764 if (WINDOWP (domain) && (w = XWINDOW (domain)) && w->face_cachels) | |
| 428 | 765 { |
| 766 if (!Dynarr_length (w->face_cachels)) | |
| 4187 | 767 reset_face_cachels (w); |
| 428 | 768 cachel = WINDOW_FACE_CACHEL (w, DEFAULT_INDEX); |
| 769 font_instance = FACE_CACHEL_FONT (cachel, Vcharset_ascii); | |
| 770 } | |
| 771 else | |
| 772 { | |
| 773 font_instance = FACE_FONT (Vdefault_face, domain, Vcharset_ascii); | |
| 774 } | |
| 775 | |
| 3707 | 776 if (UNBOUNDP (font_instance)) |
| 777 { | |
| 778 return; | |
| 779 } | |
| 780 | |
| 428 | 781 if (height) |
| 782 *height = XFONT_INSTANCE (font_instance)->height; | |
| 783 if (width) | |
| 784 *width = XFONT_INSTANCE (font_instance)->width; | |
| 785 if (ascent) | |
| 786 *ascent = XFONT_INSTANCE (font_instance)->ascent; | |
| 787 if (descent) | |
| 788 *descent = XFONT_INSTANCE (font_instance)->descent; | |
| 789 if (proportional_p) | |
| 790 *proportional_p = XFONT_INSTANCE (font_instance)->proportional_p; | |
| 791 } | |
| 792 | |
| 793 void | |
|
5047
07dcc7000bbf
put width before height consistently, fix a real bug found in the process
Ben Wing <ben@xemacs.org>
parents:
5043
diff
changeset
|
794 default_face_width_and_height (Lisp_Object domain, int *width, int *height) |
| 428 | 795 { |
|
5047
07dcc7000bbf
put width before height consistently, fix a real bug found in the process
Ben Wing <ben@xemacs.org>
parents:
5043
diff
changeset
|
796 default_face_font_info (domain, 0, 0, width, height, 0); |
| 428 | 797 } |
| 798 | |
| 799 DEFUN ("face-list", Fface_list, 0, 1, 0, /* | |
| 800 Return a list of the names of all defined faces. | |
| 801 If TEMPORARY is nil, only the permanent faces are included. | |
| 802 If it is t, only the temporary faces are included. If it is any | |
| 803 other non-nil value both permanent and temporary are included. | |
| 804 */ | |
| 805 (temporary)) | |
| 806 { | |
| 807 Lisp_Object face_list = Qnil; | |
| 808 | |
| 809 /* Added the permanent faces, if requested. */ | |
| 810 if (NILP (temporary) || !EQ (Qt, temporary)) | |
| 811 face_list = permanent_faces_list (); | |
| 812 | |
| 813 if (!NILP (temporary)) | |
| 814 { | |
| 815 struct gcpro gcpro1; | |
| 816 GCPRO1 (face_list); | |
| 817 face_list = nconc2 (face_list, temporary_faces_list ()); | |
| 818 UNGCPRO; | |
| 819 } | |
| 820 | |
| 821 return face_list; | |
| 822 } | |
| 823 | |
| 824 DEFUN ("make-face", Fmake_face, 1, 3, 0, /* | |
| 444 | 825 Define a new face with name NAME (a symbol), described by DOC-STRING. |
| 826 You can modify the font, color, etc. of a face with the set-face-* functions. | |
| 428 | 827 If the face already exists, it is unmodified. |
| 828 If TEMPORARY is non-nil, this face will cease to exist if not in use. | |
| 829 */ | |
| 830 (name, doc_string, temporary)) | |
| 831 { | |
| 832 /* This function can GC if initialized is non-zero */ | |
| 440 | 833 Lisp_Face *f; |
| 428 | 834 Lisp_Object face; |
| 835 | |
| 836 CHECK_SYMBOL (name); | |
| 837 if (!NILP (doc_string)) | |
| 838 CHECK_STRING (doc_string); | |
| 839 | |
| 840 face = Ffind_face (name); | |
| 841 if (!NILP (face)) | |
| 842 return face; | |
| 843 | |
| 844 f = allocate_face (); | |
| 793 | 845 face = wrap_face (f); |
| 428 | 846 |
| 847 f->name = name; | |
| 848 f->doc_string = doc_string; | |
| 849 f->foreground = Fmake_specifier (Qcolor); | |
| 850 set_color_attached_to (f->foreground, face, Qforeground); | |
| 851 f->background = Fmake_specifier (Qcolor); | |
| 852 set_color_attached_to (f->background, face, Qbackground); | |
| 853 f->font = Fmake_specifier (Qfont); | |
| 854 set_font_attached_to (f->font, face, Qfont); | |
| 855 f->background_pixmap = Fmake_specifier (Qimage); | |
| 856 set_image_attached_to (f->background_pixmap, face, Qbackground_pixmap); | |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
857 f->background_placement = Fmake_specifier (Qface_background_placement); |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
858 set_face_background_placement_attached_to (f->background_placement, face); |
| 428 | 859 f->display_table = Fmake_specifier (Qdisplay_table); |
| 860 f->underline = Fmake_specifier (Qface_boolean); | |
| 861 set_face_boolean_attached_to (f->underline, face, Qunderline); | |
| 862 f->strikethru = Fmake_specifier (Qface_boolean); | |
| 863 set_face_boolean_attached_to (f->strikethru, face, Qstrikethru); | |
| 864 f->highlight = Fmake_specifier (Qface_boolean); | |
| 865 set_face_boolean_attached_to (f->highlight, face, Qhighlight); | |
| 866 f->dim = Fmake_specifier (Qface_boolean); | |
| 867 set_face_boolean_attached_to (f->dim, face, Qdim); | |
| 868 f->blinking = Fmake_specifier (Qface_boolean); | |
| 869 set_face_boolean_attached_to (f->blinking, face, Qblinking); | |
| 870 f->reverse = Fmake_specifier (Qface_boolean); | |
| 871 set_face_boolean_attached_to (f->reverse, face, Qreverse); | |
| 872 if (!NILP (Vdefault_face)) | |
| 873 { | |
| 874 /* If the default face has already been created, set it as | |
| 875 the default fallback specifier for all the specifiers we | |
| 876 just created. This implements the standard "all faces | |
| 877 inherit from default" behavior. */ | |
| 878 set_specifier_fallback (f->foreground, | |
| 879 Fget (Vdefault_face, Qforeground, Qunbound)); | |
| 880 set_specifier_fallback (f->background, | |
| 881 Fget (Vdefault_face, Qbackground, Qunbound)); | |
| 882 set_specifier_fallback (f->font, | |
| 883 Fget (Vdefault_face, Qfont, Qunbound)); | |
| 884 set_specifier_fallback (f->background_pixmap, | |
| 885 Fget (Vdefault_face, Qbackground_pixmap, | |
| 886 Qunbound)); | |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
887 set_specifier_fallback (f->background_placement, |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
888 Fget (Vdefault_face, Qbackground_placement, |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
889 Qunbound)); |
| 428 | 890 set_specifier_fallback (f->display_table, |
| 891 Fget (Vdefault_face, Qdisplay_table, Qunbound)); | |
| 892 set_specifier_fallback (f->underline, | |
| 893 Fget (Vdefault_face, Qunderline, Qunbound)); | |
| 894 set_specifier_fallback (f->strikethru, | |
| 895 Fget (Vdefault_face, Qstrikethru, Qunbound)); | |
| 896 set_specifier_fallback (f->highlight, | |
| 897 Fget (Vdefault_face, Qhighlight, Qunbound)); | |
| 898 set_specifier_fallback (f->dim, | |
| 899 Fget (Vdefault_face, Qdim, Qunbound)); | |
| 900 set_specifier_fallback (f->blinking, | |
| 901 Fget (Vdefault_face, Qblinking, Qunbound)); | |
| 902 set_specifier_fallback (f->reverse, | |
| 903 Fget (Vdefault_face, Qreverse, Qunbound)); | |
| 904 } | |
| 905 | |
| 906 /* Add the face to the appropriate list. */ | |
| 907 if (NILP (temporary)) | |
| 908 Fputhash (name, face, Vpermanent_faces_cache); | |
| 909 else | |
| 910 Fputhash (name, face, Vtemporary_faces_cache); | |
| 911 | |
| 912 /* Note that it's OK if we dump faces. | |
| 913 When we start up again when we're not noninteractive, | |
| 914 `init-global-faces' is called and it resources all | |
| 915 existing faces. */ | |
| 916 if (initialized && !noninteractive) | |
| 917 { | |
| 918 struct gcpro gcpro1, gcpro2; | |
| 919 | |
| 920 GCPRO2 (name, face); | |
| 921 call1 (Qinit_face_from_resources, name); | |
| 922 UNGCPRO; | |
| 923 } | |
| 924 | |
| 925 return face; | |
| 926 } | |
| 927 | |
| 928 | |
| 929 /***************************************************************************** | |
| 930 initialization code | |
| 931 ****************************************************************************/ | |
| 932 | |
| 933 void | |
| 934 init_global_faces (struct device *d) | |
| 935 { | |
| 936 /* When making the initial terminal device, there is no Lisp code | |
| 937 loaded, so we can't do this. */ | |
| 938 if (initialized && !noninteractive) | |
| 872 | 939 call_critical_lisp_code (d, Qinit_global_faces, wrap_device (d)); |
| 428 | 940 } |
| 941 | |
| 942 void | |
| 943 init_device_faces (struct device *d) | |
| 944 { | |
| 945 /* This function can call lisp */ | |
| 946 | |
| 947 /* When making the initial terminal device, there is no Lisp code | |
| 948 loaded, so we can't do this. */ | |
| 949 if (initialized) | |
| 872 | 950 call_critical_lisp_code (d, Qinit_device_faces, wrap_device (d)); |
| 428 | 951 } |
| 952 | |
| 953 void | |
| 954 init_frame_faces (struct frame *frm) | |
| 955 { | |
| 956 /* When making the initial terminal device, there is no Lisp code | |
| 957 loaded, so we can't do this. */ | |
| 958 if (initialized) | |
| 959 { | |
| 793 | 960 Lisp_Object tframe = wrap_frame (frm); |
| 961 | |
| 428 | 962 |
| 963 /* DO NOT change the selected frame here. If the debugger goes off | |
| 4187 | 964 it will try and display on the frame being created, but it is not |
| 965 ready for that yet and a horrible death will occur. Any random | |
| 966 code depending on the selected-frame as an implicit arg should be | |
| 967 tracked down and shot. For the benefit of the one known, | |
| 968 xpm-color-symbols, make-frame sets the variable | |
| 969 Vframe_being_created to the frame it is making and sets it to nil | |
| 970 when done. Internal functions that this could trigger which are | |
| 971 currently depending on selected-frame should use this instead. It | |
| 972 is not currently visible at the lisp level. */ | |
| 428 | 973 call_critical_lisp_code (XDEVICE (FRAME_DEVICE (frm)), |
| 974 Qinit_frame_faces, tframe); | |
| 975 } | |
| 976 } | |
| 977 | |
| 978 | |
| 979 /**************************************************************************** | |
| 980 * face cache element functions * | |
| 981 ****************************************************************************/ | |
| 982 | |
| 983 /* | |
| 984 | |
| 985 #### Here is a description of how the face cache elements ought | |
| 986 to be redone. It is *NOT* how they work currently: | |
| 987 | |
| 988 However, when I started to go about implementing this, I realized | |
| 989 that there are all sorts of subtle problems with cache coherency | |
| 990 that are coming up. As it turns out, these problems don't | |
| 991 manifest themselves now due to the brute-force "kill 'em all" | |
| 992 approach to cache invalidation when faces change; but if this | |
| 993 is ever made smarter, these problems are going to come up, and | |
| 994 some of them are very non-obvious. | |
| 995 | |
| 996 I'm thinking of redoing the cache code a bit to avoid these | |
| 997 coherency problems. The bulk of the problems will arise because | |
| 998 the current display structures have simple indices into the | |
| 999 face cache, but the cache can be changed at various times, | |
| 1000 which could make the current display structures incorrect. | |
| 1001 I guess the dirty and updated flags are an attempt to fix | |
| 1002 this, but this approach doesn't really work. | |
| 1003 | |
| 1004 Here's an approach that should keep things clean and unconfused: | |
| 1005 | |
| 1006 1) Imagine a "virtual face cache" that can grow arbitrarily | |
| 1007 big and for which the only thing allowed is to add new | |
| 1008 elements. Existing elements cannot be removed or changed. | |
| 1009 This way, any pointers in the existing redisplay structure | |
| 1010 into the cache never get screwed up. (This is important | |
| 1011 because even if a cache element is out of date, if there's | |
| 1012 a pointer to it then its contents still accurately describe | |
| 1013 the way the text currently looks on the screen.) | |
| 1014 2) Each element in the virtual cache either describes exactly | |
| 1015 one face, or describes the merger of a number of faces | |
| 1016 by some process. In order to simplify things, for mergers | |
| 1017 we do not record which faces or ordering was used, but | |
| 1018 simply that this cache element is the result of merging. | |
| 1019 Unlike the current implementation, it's important that a | |
| 1020 single cache element not be used to both describe a | |
| 1021 single face and describe a merger, even if all the property | |
| 1022 values are the same. | |
| 1023 3) Each cache element can be clean or dirty. "Dirty" means | |
| 1024 that the face that the element points to has been changed; | |
| 1025 this gets set at the time the face is changed. This | |
| 1026 way, when looking up a value in the cache, you can determine | |
| 1027 whether it's out of date or not. For merged faces it | |
| 1028 does not matter -- we don't record the faces or priority | |
| 1029 used to create the merger, so it's impossible to look up | |
| 1030 one of these faces. We have to recompute it each time. | |
| 1031 Luckily, this is fine -- doing the merge is much | |
| 1032 less expensive than recomputing the properties of a | |
| 1033 single face. | |
| 1034 4) For each cache element, we keep a hash value. (In order | |
| 1035 to hash the boolean properties, we convert each of them | |
| 1036 into a different large prime number so that the hashing works | |
| 1037 well.) This allows us, when comparing runes, to properly | |
| 1038 determine whether the face for that rune has changed. | |
| 1039 This will be especially important for TTY's, where there | |
| 1040 aren't that many faces and minimizing redraw is very | |
| 1041 important. | |
| 1042 5) We can't actually keep an infinite cache, but that doesn't | |
| 1043 really matter that much. The only elements we care about | |
| 1044 are those that are used by either the current or desired | |
| 1045 display structs. Therefore, we keep a per-window | |
| 1046 redisplay iteration number, and mark each element with | |
| 1047 that number as we use it. Just after outputting the | |
| 1048 window and synching the redisplay structs, we go through | |
| 1049 the cache and invalidate all elements that are not clean | |
| 1050 elements referring to a particular face and that do not | |
| 1051 have an iteration number equal to the current one. We | |
| 1052 keep them in a chain, and use them to allocate new | |
| 1053 elements when possible instead of increasing the Dynarr. | |
| 1054 | |
| 872 | 1055 --ben (?? At least I think I wrote this!) |
| 428 | 1056 */ |
| 1057 | |
| 1058 /* mark for GC a dynarr of face cachels. */ | |
| 1059 | |
| 1060 void | |
| 1061 mark_face_cachels (face_cachel_dynarr *elements) | |
| 1062 { | |
| 1063 int elt; | |
| 1064 | |
| 1065 if (!elements) | |
| 1066 return; | |
| 1067 | |
| 1068 for (elt = 0; elt < Dynarr_length (elements); elt++) | |
| 1069 { | |
| 1070 struct face_cachel *cachel = Dynarr_atp (elements, elt); | |
| 1071 | |
| 1072 { | |
| 1073 int i; | |
| 1074 | |
| 1075 for (i = 0; i < NUM_LEADING_BYTES; i++) | |
| 1076 if (!NILP (cachel->font[i]) && !UNBOUNDP (cachel->font[i])) | |
| 1077 mark_object (cachel->font[i]); | |
| 1078 } | |
| 1079 mark_object (cachel->face); | |
| 1080 mark_object (cachel->foreground); | |
| 1081 mark_object (cachel->background); | |
| 1082 mark_object (cachel->display_table); | |
| 1083 mark_object (cachel->background_pixmap); | |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
1084 mark_object (cachel->background_placement); |
| 428 | 1085 } |
| 1086 } | |
| 1087 | |
| 1088 /* ensure that the given cachel contains an updated font value for | |
| 3094 | 1089 the given charset. Return the updated font value (which can be |
| 1090 Qunbound, so this value must not be passed unchecked to Lisp). | |
| 1091 | |
| 1092 #### Xft: This function will need to be updated for new font model. */ | |
| 428 | 1093 |
| 1094 Lisp_Object | |
| 1095 ensure_face_cachel_contains_charset (struct face_cachel *cachel, | |
| 1096 Lisp_Object domain, Lisp_Object charset) | |
| 1097 { | |
| 1098 Lisp_Object new_val; | |
| 1099 Lisp_Object face = cachel->face; | |
| 3659 | 1100 int bound = 1, final_stage = 0; |
| 428 | 1101 int offs = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE; |
| 1102 | |
| 4187 | 1103 if (!UNBOUNDP (cachel->font[offs]) && |
| 3659 | 1104 bit_vector_bit(FACE_CACHEL_FONT_UPDATED (cachel), offs)) |
| 428 | 1105 return cachel->font[offs]; |
| 1106 | |
| 1107 if (UNBOUNDP (face)) | |
| 1108 { | |
| 1109 /* a merged face. */ | |
| 1110 int i; | |
| 1111 struct window *w = XWINDOW (domain); | |
| 1112 | |
| 1113 new_val = Qunbound; | |
| 3659 | 1114 set_bit_vector_bit(FACE_CACHEL_FONT_SPECIFIED(cachel), offs, 0); |
| 1115 | |
| 428 | 1116 for (i = 0; i < cachel->nfaces; i++) |
| 1117 { | |
| 1118 struct face_cachel *oth; | |
| 1119 | |
| 1120 oth = Dynarr_atp (w->face_cachels, | |
| 1121 FACE_CACHEL_FINDEX_UNSAFE (cachel, i)); | |
| 1122 /* Tout le monde aime la recursion */ | |
| 1123 ensure_face_cachel_contains_charset (oth, domain, charset); | |
| 1124 | |
| 3659 | 1125 if (bit_vector_bit(FACE_CACHEL_FONT_SPECIFIED(oth), offs)) |
| 428 | 1126 { |
| 1127 new_val = oth->font[offs]; | |
| 3659 | 1128 set_bit_vector_bit(FACE_CACHEL_FONT_SPECIFIED(cachel), offs, 1); |
| 1129 set_bit_vector_bit | |
| 4187 | 1130 (FACE_CACHEL_FONT_FINAL_STAGE(cachel), offs, |
| 3659 | 1131 bit_vector_bit(FACE_CACHEL_FONT_FINAL_STAGE(oth), offs)); |
| 428 | 1132 break; |
| 1133 } | |
| 1134 } | |
| 1135 | |
| 3659 | 1136 if (!bit_vector_bit(FACE_CACHEL_FONT_SPECIFIED(cachel), offs)) |
| 428 | 1137 /* need to do the default face. */ |
| 1138 { | |
| 1139 struct face_cachel *oth = | |
| 1140 Dynarr_atp (w->face_cachels, DEFAULT_INDEX); | |
| 1141 ensure_face_cachel_contains_charset (oth, domain, charset); | |
| 1142 | |
| 1143 new_val = oth->font[offs]; | |
| 1144 } | |
| 1145 | |
| 4187 | 1146 if (!UNBOUNDP (cachel->font[offs]) && |
| 3659 | 1147 !EQ (cachel->font[offs], new_val)) |
| 428 | 1148 cachel->dirty = 1; |
| 3659 | 1149 set_bit_vector_bit(FACE_CACHEL_FONT_UPDATED(cachel), offs, 1); |
| 428 | 1150 cachel->font[offs] = new_val; |
| 3659 | 1151 DEBUG_FACES("just recursed on the unbound face, returning " |
| 1152 "something %s\n", UNBOUNDP(new_val) ? "not bound" | |
| 1153 : "bound"); | |
| 428 | 1154 return new_val; |
| 1155 } | |
| 1156 | |
| 3659 | 1157 do { |
| 1158 | |
| 1159 /* Lookup the face, specifying the initial stage and that fallbacks | |
| 1160 shouldn't happen. */ | |
| 1161 new_val = face_property_matching_instance (face, Qfont, charset, domain, | |
| 1162 /* ERROR_ME_DEBUG_WARN is | |
| 1163 fine here. */ | |
| 1164 ERROR_ME_DEBUG_WARN, 1, Qzero, | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1165 STAGE_INITIAL); |
| 3659 | 1166 DEBUG_FACES("just called f_p_m_i on face %s, charset %s, initial, " |
| 4187 | 1167 "result was something %s\n", |
| 1168 XSTRING_DATA(XSYMBOL_NAME(XFACE(cachel->face)->name)), | |
| 3659 | 1169 XSTRING_DATA(XSYMBOL_NAME(XCHARSET_NAME(charset))), |
| 1170 UNBOUNDP(new_val) ? "not bound" : "bound"); | |
| 1171 | |
| 1172 if (!UNBOUNDP (new_val)) break; | |
| 1173 | |
| 1174 bound = 0; | |
| 1175 /* Lookup the face again, this time allowing the fallback. If this | |
| 1176 succeeds, it'll give a font intended for the script in question, | |
| 1177 which is preferable to translating to ISO10646-1 and using the | |
|
4667
cbe5d2169270
Fix typos in face.c.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4534
diff
changeset
|
1178 fixed-width fallback. |
|
cbe5d2169270
Fix typos in face.c.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4534
diff
changeset
|
1179 |
|
cbe5d2169270
Fix typos in face.c.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4534
diff
changeset
|
1180 #### This is questionable. The problem is that unusual scripts |
|
cbe5d2169270
Fix typos in face.c.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4534
diff
changeset
|
1181 will typically fallback to the hard-coded values as the user is |
|
cbe5d2169270
Fix typos in face.c.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4534
diff
changeset
|
1182 unlikely to have specified them herself, a common complaint. */ |
| 3659 | 1183 new_val = face_property_matching_instance (face, Qfont, |
| 1184 charset, domain, | |
| 1185 ERROR_ME_DEBUG_WARN, 0, | |
| 4187 | 1186 Qzero, |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1187 STAGE_INITIAL); |
| 3659 | 1188 |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1189 DEBUG_FACES ("just called f_p_m_i on face %s, charset %s, initial, " |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1190 "allow fallback, result was something %s\n", |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1191 XSTRING_DATA (XSYMBOL_NAME (XFACE (cachel->face)->name)), |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1192 XSTRING_DATA (XSYMBOL_NAME (XCHARSET_NAME (charset))), |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1193 UNBOUNDP (new_val) ? "not bound" : "bound"); |
| 3659 | 1194 |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1195 if (!UNBOUNDP (new_val)) |
| 3659 | 1196 { |
| 1197 break; | |
| 1198 } | |
| 1199 | |
| 1200 bound = 1; | |
| 1201 /* Try the face itself with the final-stage specifiers. */ | |
| 1202 new_val = face_property_matching_instance (face, Qfont, | |
| 1203 charset, domain, | |
| 1204 ERROR_ME_DEBUG_WARN, 1, | |
| 4187 | 1205 Qzero, |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1206 STAGE_FINAL); |
| 3659 | 1207 |
| 1208 DEBUG_FACES("just called f_p_m_i on face %s, charset %s, final, " | |
| 4187 | 1209 "result was something %s\n", |
| 1210 XSTRING_DATA(XSYMBOL_NAME(XFACE(cachel->face)->name)), | |
| 3659 | 1211 XSTRING_DATA(XSYMBOL_NAME(XCHARSET_NAME(charset))), |
| 1212 UNBOUNDP(new_val) ? "not bound" : "bound"); | |
| 1213 /* Tell X11 redisplay that it should translate to iso10646-1. */ | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1214 if (!UNBOUNDP (new_val)) |
| 3659 | 1215 { |
| 1216 final_stage = 1; | |
| 1217 break; | |
| 1218 } | |
| 1219 | |
| 1220 bound = 0; | |
| 1221 | |
| 1222 /* Lookup the face again, this time both allowing the fallback and | |
| 1223 allowing its final stage to be used. */ | |
| 1224 new_val = face_property_matching_instance (face, Qfont, | |
| 1225 charset, domain, | |
| 1226 ERROR_ME_DEBUG_WARN, 0, | |
| 4187 | 1227 Qzero, |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1228 STAGE_FINAL); |
| 3659 | 1229 |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1230 DEBUG_FACES ("just called f_p_m_i on face %s, charset %s, initial, " |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1231 "allow fallback, result was something %s\n", |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1232 XSTRING_DATA (XSYMBOL_NAME (XFACE (cachel->face)->name)), |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1233 XSTRING_DATA (XSYMBOL_NAME (XCHARSET_NAME (charset))), |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1234 UNBOUNDP (new_val) ? "not bound" : "bound"); |
| 3659 | 1235 if (!UNBOUNDP(new_val)) |
| 1236 { | |
| 1237 /* Tell X11 redisplay that it should translate to iso10646-1. */ | |
| 1238 final_stage = 1; | |
| 1239 break; | |
| 1240 } | |
| 1241 } while (0); | |
| 1242 | |
| 428 | 1243 if (!UNBOUNDP (cachel->font[offs]) && !EQ (new_val, cachel->font[offs])) |
| 1244 cachel->dirty = 1; | |
| 3659 | 1245 |
| 1246 set_bit_vector_bit(FACE_CACHEL_FONT_UPDATED(cachel), offs, 1); | |
| 1247 set_bit_vector_bit(FACE_CACHEL_FONT_FINAL_STAGE(cachel), offs, | |
| 1248 final_stage); | |
| 4187 | 1249 set_bit_vector_bit(FACE_CACHEL_FONT_SPECIFIED(cachel), offs, |
| 3659 | 1250 (bound || EQ (face, Vdefault_face))); |
| 428 | 1251 cachel->font[offs] = new_val; |
| 1252 return new_val; | |
| 1253 } | |
| 1254 | |
| 1255 /* Ensure that the given cachel contains updated fonts for all | |
| 1256 the charsets specified. */ | |
| 1257 | |
| 1258 void | |
| 1259 ensure_face_cachel_complete (struct face_cachel *cachel, | |
| 1260 Lisp_Object domain, unsigned char *charsets) | |
| 1261 { | |
| 1262 int i; | |
| 1263 | |
| 1264 for (i = 0; i < NUM_LEADING_BYTES; i++) | |
| 1265 if (charsets[i]) | |
| 1266 { | |
| 826 | 1267 Lisp_Object charset = charset_by_leading_byte (i + MIN_LEADING_BYTE); |
| 428 | 1268 assert (CHARSETP (charset)); |
| 1269 ensure_face_cachel_contains_charset (cachel, domain, charset); | |
| 1270 } | |
| 1271 } | |
| 1272 | |
| 1273 void | |
| 1274 face_cachel_charset_font_metric_info (struct face_cachel *cachel, | |
| 1275 unsigned char *charsets, | |
| 1276 struct font_metric_info *fm) | |
| 1277 { | |
| 1278 int i; | |
| 1279 | |
| 1280 fm->width = 1; | |
| 1281 fm->height = fm->ascent = 1; | |
| 1282 fm->descent = 0; | |
| 1283 fm->proportional_p = 0; | |
| 1284 | |
| 1285 for (i = 0; i < NUM_LEADING_BYTES; i++) | |
| 1286 { | |
| 1287 if (charsets[i]) | |
| 1288 { | |
| 826 | 1289 Lisp_Object charset = charset_by_leading_byte (i + MIN_LEADING_BYTE); |
| 428 | 1290 Lisp_Object font_instance = FACE_CACHEL_FONT (cachel, charset); |
| 440 | 1291 Lisp_Font_Instance *fi = XFONT_INSTANCE (font_instance); |
| 428 | 1292 |
| 1293 assert (CHARSETP (charset)); | |
| 1294 assert (FONT_INSTANCEP (font_instance)); | |
| 1295 | |
| 1296 if (fm->ascent < (int) fi->ascent) fm->ascent = (int) fi->ascent; | |
| 1297 if (fm->descent < (int) fi->descent) fm->descent = (int) fi->descent; | |
| 1298 fm->height = fm->ascent + fm->descent; | |
| 1299 if (fi->proportional_p) | |
| 1300 fm->proportional_p = 1; | |
| 1301 if (EQ (charset, Vcharset_ascii)) | |
| 1302 fm->width = fi->width; | |
| 1303 } | |
| 1304 } | |
| 1305 } | |
| 1306 | |
| 1307 #define FROB(field) \ | |
| 1308 do { \ | |
| 1309 Lisp_Object new_val = \ | |
| 1310 FACE_PROPERTY_INSTANCE (face, Q##field, domain, 1, Qzero); \ | |
| 1311 int bound = 1; \ | |
| 1312 if (UNBOUNDP (new_val)) \ | |
| 1313 { \ | |
| 1314 bound = 0; \ | |
| 1315 new_val = FACE_PROPERTY_INSTANCE (face, Q##field, domain, 0, Qzero); \ | |
| 1316 } \ | |
| 1317 if (!EQ (new_val, cachel->field)) \ | |
| 1318 { \ | |
| 1319 cachel->field = new_val; \ | |
| 1320 cachel->dirty = 1; \ | |
| 1321 } \ | |
| 1322 cachel->field##_specified = (bound || default_face); \ | |
| 1323 } while (0) | |
| 1324 | |
| 446 | 1325 /* |
| 1326 * A face's background pixmap will override the face's | |
| 1327 * background color. But the background pixmap of the | |
| 1328 * default face should not override the background color of | |
| 1329 * a face if the background color has been specified or | |
| 1330 * inherited. | |
| 1331 * | |
| 1332 * To accomplish this we remove the background pixmap of the | |
| 1333 * cachel and mark it as having been specified so that cachel | |
| 1334 * merging won't override it later. | |
| 1335 */ | |
| 1336 #define MAYBE_UNFROB_BACKGROUND_PIXMAP \ | |
| 1337 do \ | |
| 1338 { \ | |
| 1339 if (! default_face \ | |
| 1340 && cachel->background_specified \ | |
| 1341 && ! cachel->background_pixmap_specified) \ | |
| 1342 { \ | |
| 1343 cachel->background_pixmap = Qunbound; \ | |
| 1344 cachel->background_pixmap_specified = 1; \ | |
| 1345 } \ | |
| 1346 } while (0) | |
| 1347 | |
| 1348 | |
| 1349 /* Add a cachel for the given face to the given window's cache. */ | |
| 1350 | |
| 1351 static void | |
| 1352 add_face_cachel (struct window *w, Lisp_Object face) | |
| 1353 { | |
| 1354 int must_finish_frobbing = ! WINDOW_FACE_CACHEL (w, DEFAULT_INDEX); | |
| 1355 struct face_cachel new_cachel; | |
| 1356 Lisp_Object domain; | |
| 1357 | |
| 1358 reset_face_cachel (&new_cachel); | |
| 793 | 1359 domain = wrap_window (w); |
| 446 | 1360 update_face_cachel_data (&new_cachel, domain, face); |
| 1361 Dynarr_add (w->face_cachels, new_cachel); | |
| 1362 | |
| 1363 /* The face's background pixmap have not yet been frobbed (see comment | |
|
4667
cbe5d2169270
Fix typos in face.c.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4534
diff
changeset
|
1364 in update_face_cachel_data), so we have to do it now */ |
| 446 | 1365 if (must_finish_frobbing) |
| 1366 { | |
| 1367 int default_face = EQ (face, Vdefault_face); | |
|
4844
91b3d00e717f
Various cleanups for Dynarr code, from Unicode-internal ws
Ben Wing <ben@xemacs.org>
parents:
4827
diff
changeset
|
1368 struct face_cachel *cachel = Dynarr_lastp (w->face_cachels); |
| 446 | 1369 |
| 1370 FROB (background_pixmap); | |
| 1371 MAYBE_UNFROB_BACKGROUND_PIXMAP; | |
| 1372 } | |
| 1373 } | |
| 1374 | |
| 1375 /* Called when the updated flag has been cleared on a cachel. | |
| 1376 This function returns 1 if the caller must finish the update (see comment | |
| 1377 below), 0 otherwise. | |
| 1378 */ | |
| 1379 | |
| 1380 void | |
| 1381 update_face_cachel_data (struct face_cachel *cachel, | |
| 1382 Lisp_Object domain, | |
| 1383 Lisp_Object face) | |
| 1384 { | |
| 1385 if (XFACE (face)->dirty || UNBOUNDP (cachel->face)) | |
| 1386 { | |
| 1387 int default_face = EQ (face, Vdefault_face); | |
| 1388 cachel->face = face; | |
| 1389 | |
| 1390 /* We normally only set the _specified flags if the value was | |
| 4187 | 1391 actually bound. The exception is for the default face where |
| 1392 we always set it since it is the ultimate fallback. */ | |
| 446 | 1393 |
| 428 | 1394 FROB (foreground); |
| 1395 FROB (background); | |
| 1396 FROB (display_table); | |
| 446 | 1397 |
| 1398 /* #### WARNING: the background pixmap property of faces is currently | |
| 1399 the only one dealing with images. The problem we have here is that | |
| 1400 frobbing the background pixmap might lead to image instantiation | |
| 1401 which in turn might require that the cache we're building be up to | |
| 1402 date, hence a crash. Here's a typical scenario of this: | |
| 1403 | |
|
4667
cbe5d2169270
Fix typos in face.c.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4534
diff
changeset
|
1404 - a new window is created and its face cache elements are |
| 446 | 1405 initialized through a call to reset_face_cachels[1]. At that point, |
| 1406 the cache for the default and modeline faces (normaly taken care of | |
| 1407 by redisplay itself) are null. | |
| 1408 - the default face has a background pixmap which needs to be | |
| 1409 instantiated right here, as a consequence of cache initialization. | |
| 1410 - the background pixmap image happens to be instantiated as a string | |
| 1411 (this happens on tty's for instance). | |
| 1412 - In order to do this, we need to compute the string geometry. | |
| 1413 - In order to do this, we might have to access the window's default | |
| 1414 face cache. But this is the cache we're building right now, it is | |
| 1415 null. | |
| 1416 - BARF !!!!! | |
| 428 | 1417 |
| 446 | 1418 To sum up, this means that it is in general unsafe to instantiate |
| 1419 images before face cache updating is complete (appart from image | |
| 1420 related face attributes). The solution we use below is to actually | |
| 1421 detect whether we're building the window's face_cachels for the first | |
| 1422 time, and simply NOT frob the background pixmap in that case. If | |
| 1423 other image-related face attributes are ever implemented, they should | |
| 1424 be protected the same way right here. | |
| 1425 | |
| 1426 One note: | |
| 1427 * See comment in `default_face_font_info' in face.c. Who wrote it ? | |
| 1428 Maybe we have the begining of an answer here ? | |
| 1429 | |
| 1430 Footnotes: | |
| 1431 [1] See comment at the top of `allocate_window' in window.c. | |
| 1432 | |
| 1433 -- didier | |
| 1434 */ | |
| 1435 if (! WINDOWP (domain) | |
| 1436 || WINDOW_FACE_CACHEL (DOMAIN_XWINDOW (domain), DEFAULT_INDEX)) | |
| 428 | 1437 { |
| 446 | 1438 FROB (background_pixmap); |
| 1439 MAYBE_UNFROB_BACKGROUND_PIXMAP; | |
| 428 | 1440 } |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
1441 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
1442 FROB (background_placement); |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
1443 |
| 428 | 1444 #undef FROB |
| 446 | 1445 #undef MAYBE_UNFROB_BACKGROUND_PIXMAP |
| 428 | 1446 |
| 1447 ensure_face_cachel_contains_charset (cachel, domain, Vcharset_ascii); | |
| 1448 | |
| 1449 #define FROB(field) \ | |
| 1450 do { \ | |
| 1451 Lisp_Object new_val = \ | |
| 1452 FACE_PROPERTY_INSTANCE (face, Q##field, domain, 1, Qzero); \ | |
| 1453 int bound = 1; \ | |
| 1454 unsigned int new_val_int; \ | |
| 1455 if (UNBOUNDP (new_val)) \ | |
| 1456 { \ | |
| 1457 bound = 0; \ | |
| 1458 new_val = FACE_PROPERTY_INSTANCE (face, Q##field, domain, 0, Qzero); \ | |
| 1459 } \ | |
| 1460 new_val_int = EQ (new_val, Qt); \ | |
| 1461 if (cachel->field != new_val_int) \ | |
| 1462 { \ | |
| 1463 cachel->field = new_val_int; \ | |
| 1464 cachel->dirty = 1; \ | |
| 1465 } \ | |
| 1466 cachel->field##_specified = bound; \ | |
| 1467 } while (0) | |
| 1468 | |
| 1469 FROB (underline); | |
| 1470 FROB (strikethru); | |
| 1471 FROB (highlight); | |
| 1472 FROB (dim); | |
| 1473 FROB (reverse); | |
| 1474 FROB (blinking); | |
| 1475 #undef FROB | |
| 1476 } | |
| 1477 | |
| 1478 cachel->updated = 1; | |
| 1479 } | |
| 1480 | |
| 1481 /* Merge the cachel identified by FINDEX in window W into the given | |
| 1482 cachel. */ | |
| 1483 | |
| 1484 static void | |
| 1485 merge_face_cachel_data (struct window *w, face_index findex, | |
| 1486 struct face_cachel *cachel) | |
| 1487 { | |
| 3659 | 1488 int offs; |
| 1489 | |
| 428 | 1490 #define FINDEX_FIELD(field) \ |
| 1491 Dynarr_atp (w->face_cachels, findex)->field | |
| 1492 | |
| 1493 #define FROB(field) \ | |
| 1494 do { \ | |
| 1495 if (!cachel->field##_specified && FINDEX_FIELD (field##_specified)) \ | |
| 1496 { \ | |
| 1497 cachel->field = FINDEX_FIELD (field); \ | |
| 1498 cachel->field##_specified = 1; \ | |
| 1499 cachel->dirty = 1; \ | |
| 1500 } \ | |
| 1501 } while (0) | |
| 1502 | |
| 1503 FROB (foreground); | |
| 1504 FROB (background); | |
| 1505 FROB (display_table); | |
| 1506 FROB (background_pixmap); | |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
1507 FROB (background_placement); |
| 428 | 1508 FROB (underline); |
| 1509 FROB (strikethru); | |
| 1510 FROB (highlight); | |
| 1511 FROB (dim); | |
| 1512 FROB (reverse); | |
| 1513 FROB (blinking); | |
| 1514 | |
| 3659 | 1515 for (offs = 0; offs < NUM_LEADING_BYTES; ++offs) |
| 1516 { | |
| 1517 if (!(bit_vector_bit(FACE_CACHEL_FONT_SPECIFIED(cachel), offs)) | |
| 1518 && bit_vector_bit(FACE_CACHEL_FONT_SPECIFIED | |
| 1519 (Dynarr_atp(w->face_cachels, findex)), offs)) | |
| 1520 { | |
| 1521 cachel->font[offs] = FINDEX_FIELD (font[offs]); | |
| 1522 set_bit_vector_bit(FACE_CACHEL_FONT_SPECIFIED(cachel), offs, 1); | |
| 1523 /* Also propagate whether we're translating to Unicode for the | |
| 1524 given face. */ | |
| 4187 | 1525 set_bit_vector_bit(FACE_CACHEL_FONT_FINAL_STAGE(cachel), offs, |
| 3659 | 1526 bit_vector_bit(FACE_CACHEL_FONT_FINAL_STAGE |
| 1527 (Dynarr_atp(w->face_cachels, | |
| 1528 findex)), offs)); | |
| 1529 cachel->dirty = 1; | |
| 1530 } | |
| 1531 } | |
| 428 | 1532 #undef FROB |
| 1533 #undef FINDEX_FIELD | |
| 1534 | |
| 1535 cachel->updated = 1; | |
| 1536 } | |
| 1537 | |
| 1538 /* Initialize a cachel. */ | |
| 3094 | 1539 /* #### Xft: this function will need to be changed for new font model. */ |
| 428 | 1540 |
| 1541 void | |
| 1542 reset_face_cachel (struct face_cachel *cachel) | |
| 1543 { | |
| 1544 xzero (*cachel); | |
| 1545 cachel->face = Qunbound; | |
| 1546 cachel->nfaces = 0; | |
| 1547 cachel->merged_faces = 0; | |
| 1548 cachel->foreground = Qunbound; | |
| 1549 cachel->background = Qunbound; | |
| 1550 { | |
| 1551 int i; | |
| 1552 | |
| 1553 for (i = 0; i < NUM_LEADING_BYTES; i++) | |
| 1554 cachel->font[i] = Qunbound; | |
| 1555 } | |
| 1556 cachel->display_table = Qunbound; | |
| 1557 cachel->background_pixmap = Qunbound; | |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
1558 cachel->background_placement = Qunbound; |
| 3659 | 1559 FACE_CACHEL_FONT_SPECIFIED (cachel)->size = sizeof(cachel->font_specified); |
| 1560 FACE_CACHEL_FONT_UPDATED (cachel)->size = sizeof(cachel->font_updated); | |
| 428 | 1561 } |
| 1562 | |
| 1563 /* Retrieve the index to a cachel for window W that corresponds to | |
| 1564 the specified face. If necessary, add a new element to the | |
| 1565 cache. */ | |
| 1566 | |
| 1567 face_index | |
| 1568 get_builtin_face_cache_index (struct window *w, Lisp_Object face) | |
| 1569 { | |
| 1570 int elt; | |
| 1571 | |
| 1572 if (noninteractive) | |
| 1573 return 0; | |
| 1574 | |
| 1575 for (elt = 0; elt < Dynarr_length (w->face_cachels); elt++) | |
| 1576 { | |
| 1577 struct face_cachel *cachel = WINDOW_FACE_CACHEL (w, elt); | |
| 1578 | |
| 1579 if (EQ (cachel->face, face)) | |
| 1580 { | |
| 793 | 1581 Lisp_Object window = wrap_window (w); |
| 1582 | |
| 428 | 1583 if (!cachel->updated) |
| 1584 update_face_cachel_data (cachel, window, face); | |
| 1585 return elt; | |
| 1586 } | |
| 1587 } | |
| 1588 | |
| 1589 /* If we didn't find the face, add it and then return its index. */ | |
| 1590 add_face_cachel (w, face); | |
| 1591 return elt; | |
| 1592 } | |
| 1593 | |
| 1594 void | |
| 1595 reset_face_cachels (struct window *w) | |
| 1596 { | |
| 1597 /* #### Not initialized in batch mode for the stream device. */ | |
| 1598 if (w->face_cachels) | |
| 1599 { | |
| 1600 int i; | |
| 4208 | 1601 face_index fi; |
| 428 | 1602 |
| 1603 for (i = 0; i < Dynarr_length (w->face_cachels); i++) | |
| 1604 { | |
| 1605 struct face_cachel *cachel = Dynarr_atp (w->face_cachels, i); | |
| 1606 if (cachel->merged_faces) | |
| 1607 Dynarr_free (cachel->merged_faces); | |
| 1608 } | |
| 1609 Dynarr_reset (w->face_cachels); | |
| 4187 | 1610 /* #### NOTE: be careful with the order ! |
| 1611 The cpp macros DEFAULT_INDEX and MODELINE_INDEX defined in | |
| 4208 | 1612 redisplay.h depend on the code below. Please make sure to assert the |
| 1613 correct values if you ever add new built-in faces here. | |
| 4187 | 1614 -- dvl */ |
| 4208 | 1615 fi = get_builtin_face_cache_index (w, Vdefault_face); |
| 4210 | 1616 assert (noninteractive || fi == DEFAULT_INDEX); |
| 4208 | 1617 fi = get_builtin_face_cache_index (w, Vmodeline_face); |
| 4210 | 1618 assert (noninteractive || fi == MODELINE_INDEX); |
| 428 | 1619 XFRAME (w->frame)->window_face_cache_reset = 1; |
| 1620 } | |
| 1621 } | |
| 1622 | |
| 1623 void | |
| 1624 mark_face_cachels_as_clean (struct window *w) | |
| 1625 { | |
| 1626 int elt; | |
| 1627 | |
| 1628 for (elt = 0; elt < Dynarr_length (w->face_cachels); elt++) | |
| 1629 Dynarr_atp (w->face_cachels, elt)->dirty = 0; | |
| 1630 } | |
| 1631 | |
| 3094 | 1632 /* #### Xft: this function will need to be changed for new font model. */ |
| 428 | 1633 void |
| 1634 mark_face_cachels_as_not_updated (struct window *w) | |
| 1635 { | |
| 1636 int elt; | |
| 1637 | |
| 1638 for (elt = 0; elt < Dynarr_length (w->face_cachels); elt++) | |
| 1639 { | |
| 1640 struct face_cachel *cachel = Dynarr_atp (w->face_cachels, elt); | |
| 1641 | |
| 1642 cachel->updated = 0; | |
| 4187 | 1643 memset(FACE_CACHEL_FONT_UPDATED(cachel)->bits, 0, |
| 3659 | 1644 BIT_VECTOR_LONG_STORAGE (NUM_LEADING_BYTES)); |
| 428 | 1645 } |
| 1646 } | |
| 1647 | |
| 1648 #ifdef MEMORY_USAGE_STATS | |
| 1649 | |
| 1650 int | |
| 1651 compute_face_cachel_usage (face_cachel_dynarr *face_cachels, | |
|
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5128
diff
changeset
|
1652 struct usage_stats *ustats) |
| 428 | 1653 { |
| 1654 int total = 0; | |
| 1655 | |
| 1656 if (face_cachels) | |
| 1657 { | |
| 1658 int i; | |
| 1659 | |
|
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5128
diff
changeset
|
1660 total += Dynarr_memory_usage (face_cachels, ustats); |
| 428 | 1661 for (i = 0; i < Dynarr_length (face_cachels); i++) |
| 1662 { | |
| 1663 int_dynarr *merged = Dynarr_at (face_cachels, i).merged_faces; | |
| 1664 if (merged) | |
|
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5128
diff
changeset
|
1665 total += Dynarr_memory_usage (merged, ustats); |
| 428 | 1666 } |
| 1667 } | |
| 1668 | |
| 1669 return total; | |
| 1670 } | |
| 1671 | |
| 1672 #endif /* MEMORY_USAGE_STATS */ | |
| 1673 | |
| 1674 | |
| 1675 /***************************************************************************** | |
| 1676 * merged face functions * | |
| 1677 *****************************************************************************/ | |
| 1678 | |
| 1679 /* Compare two merged face cachels to determine whether we have to add | |
| 1680 a new entry to the face cache. | |
| 1681 | |
| 1682 Note that we do not compare the attributes, but just the faces the | |
| 1683 cachels are based on. If they are the same, then the cachels certainly | |
| 1684 ought to have the same attributes, except in the case where fonts | |
| 1685 for different charsets have been determined in the two -- and in that | |
| 1686 case this difference is fine. */ | |
| 1687 | |
| 1688 static int | |
| 1689 compare_merged_face_cachels (struct face_cachel *cachel1, | |
| 1690 struct face_cachel *cachel2) | |
| 1691 { | |
| 1692 int i; | |
| 1693 | |
| 1694 if (!EQ (cachel1->face, cachel2->face) | |
| 1695 || cachel1->nfaces != cachel2->nfaces) | |
| 1696 return 0; | |
| 1697 | |
| 1698 for (i = 0; i < cachel1->nfaces; i++) | |
| 1699 if (FACE_CACHEL_FINDEX_UNSAFE (cachel1, i) | |
| 1700 != FACE_CACHEL_FINDEX_UNSAFE (cachel2, i)) | |
| 1701 return 0; | |
| 1702 | |
| 1703 return 1; | |
| 1704 } | |
| 1705 | |
| 1706 /* Retrieve the index to a cachel for window W that corresponds to | |
| 1707 the specified cachel. If necessary, add a new element to the | |
| 1708 cache. This is similar to get_builtin_face_cache_index() but | |
| 1709 is intended for merged cachels rather than for cachels representing | |
| 1710 just a face. | |
| 1711 | |
| 1712 Note that a merged cachel for just one face is not the same as | |
| 1713 the simple cachel for that face, because it is also merged with | |
| 1714 the default face. */ | |
| 1715 | |
| 1716 static face_index | |
| 1717 get_merged_face_cache_index (struct window *w, | |
| 1718 struct face_cachel *merged_cachel) | |
| 1719 { | |
| 1720 int elt; | |
| 1721 int cache_size = Dynarr_length (w->face_cachels); | |
| 1722 | |
| 1723 for (elt = 0; elt < cache_size; elt++) | |
| 1724 { | |
| 1725 struct face_cachel *cachel = | |
| 1726 Dynarr_atp (w->face_cachels, elt); | |
| 1727 | |
| 1728 if (compare_merged_face_cachels (cachel, merged_cachel)) | |
| 1729 return elt; | |
| 1730 } | |
| 1731 | |
| 1732 /* We didn't find it so add this instance to the cache. */ | |
| 1733 merged_cachel->updated = 1; | |
| 1734 merged_cachel->dirty = 1; | |
| 1735 Dynarr_add (w->face_cachels, *merged_cachel); | |
| 1736 return cache_size; | |
| 1737 } | |
| 1738 | |
| 1739 face_index | |
| 1740 get_extent_fragment_face_cache_index (struct window *w, | |
| 1741 struct extent_fragment *ef) | |
| 1742 { | |
| 1743 struct face_cachel cachel; | |
| 1744 int len = Dynarr_length (ef->extents); | |
| 1745 face_index findex = 0; | |
| 1746 | |
| 1747 /* Optimize the default case. */ | |
| 1748 if (len == 0) | |
| 1749 return DEFAULT_INDEX; | |
| 1750 else | |
| 1751 { | |
| 1752 int i; | |
| 1753 | |
| 1754 /* Merge the faces of the extents together in order. */ | |
| 1755 | |
| 1756 reset_face_cachel (&cachel); | |
| 1757 | |
| 1758 for (i = len - 1; i >= 0; i--) | |
| 1759 { | |
| 1760 EXTENT current = Dynarr_at (ef->extents, i); | |
| 1761 int has_findex = 0; | |
| 1762 Lisp_Object face = extent_face (current); | |
| 1763 | |
| 1764 if (FACEP (face)) | |
| 1765 { | |
| 1766 findex = get_builtin_face_cache_index (w, face); | |
| 1767 has_findex = 1; | |
| 1768 merge_face_cachel_data (w, findex, &cachel); | |
| 1769 } | |
| 1770 /* remember, we're called from within redisplay | |
| 1771 so we can't error. */ | |
| 1772 else while (CONSP (face)) | |
| 1773 { | |
| 1774 Lisp_Object one_face = XCAR (face); | |
| 1775 if (FACEP (one_face)) | |
| 1776 { | |
| 1777 findex = get_builtin_face_cache_index (w, one_face); | |
| 1778 merge_face_cachel_data (w, findex, &cachel); | |
| 1779 | |
| 1780 /* code duplication here but there's no clean | |
| 1781 way to avoid it. */ | |
| 1782 if (cachel.nfaces >= NUM_STATIC_CACHEL_FACES) | |
| 1783 { | |
| 1784 if (!cachel.merged_faces) | |
| 1785 cachel.merged_faces = Dynarr_new (int); | |
| 1786 Dynarr_add (cachel.merged_faces, findex); | |
| 1787 } | |
| 1788 else | |
| 1789 cachel.merged_faces_static[cachel.nfaces] = findex; | |
| 1790 cachel.nfaces++; | |
| 1791 } | |
| 1792 face = XCDR (face); | |
| 1793 } | |
| 1794 | |
| 1795 if (has_findex) | |
| 1796 { | |
| 1797 if (cachel.nfaces >= NUM_STATIC_CACHEL_FACES) | |
| 1798 { | |
| 1799 if (!cachel.merged_faces) | |
| 1800 cachel.merged_faces = Dynarr_new (int); | |
| 1801 Dynarr_add (cachel.merged_faces, findex); | |
| 1802 } | |
| 1803 else | |
| 1804 cachel.merged_faces_static[cachel.nfaces] = findex; | |
| 1805 cachel.nfaces++; | |
| 1806 } | |
| 1807 } | |
| 1808 | |
| 1809 /* Now finally merge in the default face. */ | |
| 1810 findex = get_builtin_face_cache_index (w, Vdefault_face); | |
| 1811 merge_face_cachel_data (w, findex, &cachel); | |
| 1812 | |
| 444 | 1813 findex = get_merged_face_cache_index (w, &cachel); |
| 1814 if (cachel.merged_faces && | |
| 1815 /* merged_faces did not get stored and available via return value */ | |
| 1816 Dynarr_at (w->face_cachels, findex).merged_faces != | |
| 1817 cachel.merged_faces) | |
| 1818 { | |
| 1819 Dynarr_free (cachel.merged_faces); | |
| 1820 cachel.merged_faces = 0; | |
| 1821 } | |
| 1822 return findex; | |
| 428 | 1823 } |
| 1824 } | |
| 1825 | |
| 3094 | 1826 /* Return a cache index for window W from merging the faces in FACE_LIST. |
| 1827 COUNT is the number of faces in the list. | |
| 1828 | |
| 1829 The default face should not be included in the list, as it is always | |
| 1830 implicitly merged into the cachel. | |
| 1831 | |
| 1832 WARNING: this interface may change. */ | |
| 1833 | |
| 1834 face_index | |
| 1835 merge_face_list_to_cache_index (struct window *w, | |
| 1836 Lisp_Object *face_list, int count) | |
| 1837 { | |
| 1838 int i; | |
| 1839 face_index findex = 0; | |
| 1840 struct face_cachel cachel; | |
| 1841 | |
| 1842 reset_face_cachel (&cachel); | |
| 1843 | |
| 1844 for (i = 0; i < count; i++) | |
| 1845 { | |
| 1846 Lisp_Object face = face_list[i]; | |
| 1847 | |
| 1848 if (!NILP (face)) | |
| 1849 { | |
| 1850 CHECK_FACE(face); /* #### presumably unnecessary */ | |
| 1851 findex = get_builtin_face_cache_index (w, face); | |
| 1852 merge_face_cachel_data (w, findex, &cachel); | |
| 1853 } | |
| 1854 } | |
| 1855 | |
| 1856 /* Now finally merge in the default face. */ | |
| 1857 findex = get_builtin_face_cache_index (w, Vdefault_face); | |
| 1858 merge_face_cachel_data (w, findex, &cachel); | |
| 1859 | |
| 1860 return get_merged_face_cache_index (w, &cachel); | |
| 1861 } | |
| 1862 | |
| 428 | 1863 |
| 1864 /***************************************************************************** | |
| 1865 interface functions | |
| 1866 ****************************************************************************/ | |
| 1867 | |
| 1868 static void | |
| 1869 update_EmacsFrame (Lisp_Object frame, Lisp_Object name) | |
| 1870 { | |
| 1871 struct frame *frm = XFRAME (frame); | |
| 1872 | |
| 3676 | 1873 if (!FRAME_LIVE_P(frm)) |
| 1874 return; | |
| 1875 | |
| 428 | 1876 if (EQ (name, Qfont)) |
| 1877 MARK_FRAME_SIZE_SLIPPED (frm); | |
| 1878 | |
| 1879 MAYBE_FRAMEMETH (frm, update_frame_external_traits, (frm, name)); | |
| 1880 } | |
| 1881 | |
| 1882 static void | |
| 1883 update_EmacsFrames (Lisp_Object locale, Lisp_Object name) | |
| 1884 { | |
| 1885 if (FRAMEP (locale)) | |
| 1886 { | |
| 1887 update_EmacsFrame (locale, name); | |
| 1888 } | |
| 1889 else if (DEVICEP (locale)) | |
| 1890 { | |
| 1891 Lisp_Object frmcons; | |
| 1892 | |
| 1893 DEVICE_FRAME_LOOP (frmcons, XDEVICE (locale)) | |
| 1894 update_EmacsFrame (XCAR (frmcons), name); | |
| 1895 } | |
| 1896 else if (EQ (locale, Qglobal) || EQ (locale, Qfallback)) | |
| 1897 { | |
| 1898 Lisp_Object frmcons, devcons, concons; | |
| 1899 | |
| 1900 FRAME_LOOP_NO_BREAK (frmcons, devcons, concons) | |
| 1901 update_EmacsFrame (XCAR (frmcons), name); | |
| 1902 } | |
| 1903 } | |
| 1904 | |
| 1905 void | |
| 1906 update_frame_face_values (struct frame *f) | |
| 1907 { | |
| 793 | 1908 Lisp_Object frm = wrap_frame (f); |
| 428 | 1909 |
| 1910 update_EmacsFrame (frm, Qforeground); | |
| 1911 update_EmacsFrame (frm, Qbackground); | |
| 1912 update_EmacsFrame (frm, Qfont); | |
| 1913 } | |
| 1914 | |
| 1915 void | |
| 1916 face_property_was_changed (Lisp_Object face, Lisp_Object property, | |
| 1917 Lisp_Object locale) | |
| 1918 { | |
| 1919 int default_face = EQ (face, Vdefault_face); | |
| 1920 | |
| 1921 /* If the locale could affect the frame value, then call | |
| 1922 update_EmacsFrames just in case. */ | |
| 1923 if (default_face && | |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
1924 (EQ (property, Qforeground) || |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
1925 EQ (property, Qbackground) || |
| 428 | 1926 EQ (property, Qfont))) |
| 1927 update_EmacsFrames (locale, property); | |
| 1928 | |
| 1929 if (WINDOWP (locale)) | |
| 1930 { | |
| 1931 MARK_FRAME_FACES_CHANGED (XFRAME (XWINDOW (locale)->frame)); | |
| 1932 } | |
| 1933 else if (FRAMEP (locale)) | |
| 1934 { | |
| 1935 MARK_FRAME_FACES_CHANGED (XFRAME (locale)); | |
| 1936 } | |
| 1937 else if (DEVICEP (locale)) | |
| 1938 { | |
| 1939 MARK_DEVICE_FRAMES_FACES_CHANGED (XDEVICE (locale)); | |
| 1940 } | |
| 1941 else | |
| 1942 { | |
| 1943 Lisp_Object devcons, concons; | |
| 1944 DEVICE_LOOP_NO_BREAK (devcons, concons) | |
| 1945 MARK_DEVICE_FRAMES_FACES_CHANGED (XDEVICE (XCAR (devcons))); | |
| 1946 } | |
| 1947 | |
| 1948 /* | |
| 1949 * This call to update_faces_inheritance isn't needed and makes | |
| 1950 * creating and modifying faces _very_ slow. The point of | |
| 1951 * update_face_inheritances is to find all faces that inherit | |
| 1952 * directly from this face property and set the specifier "dirty" | |
| 1953 * flag on the corresponding specifier. This forces recaching of | |
| 1954 * cached specifier values in frame and window struct slots. But | |
| 1955 * currently no face properties are cached in frame and window | |
| 1956 * struct slots, so calling this function does nothing useful! | |
| 1957 * | |
| 1958 * Further, since update_faces_inheritance maps over the whole | |
| 1959 * face table every time it is called, it gets terribly slow when | |
| 1960 * there are many faces. Creating 500 faces on a 50Mhz 486 took | |
| 1961 * 433 seconds when update_faces_inheritance was called. With the | |
| 1962 * call commented out, creating those same 500 faces took 0.72 | |
| 1963 * seconds. | |
| 1964 */ | |
| 1965 /* update_faces_inheritance (face, property);*/ | |
| 1966 XFACE (face)->dirty = 1; | |
| 1967 } | |
| 1968 | |
| 1969 DEFUN ("copy-face", Fcopy_face, 2, 6, 0, /* | |
| 1970 Define and return a new face which is a copy of an existing one, | |
| 1971 or makes an already-existing face be exactly like another. | |
| 1972 LOCALE, TAG-SET, EXACT-P, and HOW-TO-ADD are as in `copy-specifier'. | |
| 1973 */ | |
| 1974 (old_face, new_name, locale, tag_set, exact_p, how_to_add)) | |
| 1975 { | |
| 440 | 1976 Lisp_Face *fold, *fnew; |
| 428 | 1977 Lisp_Object new_face = Qnil; |
| 1978 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; | |
| 1979 | |
| 1980 old_face = Fget_face (old_face); | |
| 1981 | |
| 1982 /* We GCPRO old_face because it might be temporary, and GCing could | |
| 1983 occur in various places below. */ | |
| 1984 GCPRO4 (tag_set, locale, old_face, new_face); | |
| 1985 /* check validity of how_to_add now. */ | |
| 1986 decode_how_to_add_specification (how_to_add); | |
| 1987 /* and of tag_set. */ | |
| 1988 tag_set = decode_specifier_tag_set (tag_set); | |
| 1989 /* and of locale. */ | |
| 1990 locale = decode_locale_list (locale); | |
| 1991 | |
| 1992 new_face = Ffind_face (new_name); | |
| 1993 if (NILP (new_face)) | |
| 1994 { | |
| 1995 Lisp_Object temp; | |
| 1996 | |
| 1997 CHECK_SYMBOL (new_name); | |
| 1998 | |
| 1999 /* Create the new face with the same status as the old face. */ | |
| 2000 temp = (NILP (Fgethash (old_face, Vtemporary_faces_cache, Qnil)) | |
| 2001 ? Qnil | |
| 2002 : Qt); | |
| 2003 | |
| 2004 new_face = Fmake_face (new_name, Qnil, temp); | |
| 2005 } | |
| 2006 | |
| 2007 fold = XFACE (old_face); | |
| 2008 fnew = XFACE (new_face); | |
| 2009 | |
| 2010 #define COPY_PROPERTY(property) \ | |
| 2011 Fcopy_specifier (fold->property, fnew->property, \ | |
| 4187 | 2012 locale, tag_set, exact_p, how_to_add); |
| 428 | 2013 |
| 2014 COPY_PROPERTY (foreground); | |
| 2015 COPY_PROPERTY (background); | |
| 2016 COPY_PROPERTY (font); | |
| 2017 COPY_PROPERTY (display_table); | |
| 2018 COPY_PROPERTY (background_pixmap); | |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
2019 COPY_PROPERTY (background_placement); |
| 428 | 2020 COPY_PROPERTY (underline); |
| 2021 COPY_PROPERTY (strikethru); | |
| 2022 COPY_PROPERTY (highlight); | |
| 2023 COPY_PROPERTY (dim); | |
| 2024 COPY_PROPERTY (blinking); | |
| 2025 COPY_PROPERTY (reverse); | |
| 2026 #undef COPY_PROPERTY | |
| 2027 /* #### should it copy the individual specifiers, if they exist? */ | |
| 2028 fnew->plist = Fcopy_sequence (fold->plist); | |
| 2029 | |
| 2030 UNGCPRO; | |
| 2031 | |
| 2032 return new_name; | |
| 2033 } | |
| 2034 | |
| 3659 | 2035 #ifdef MULE |
| 2036 | |
| 3918 | 2037 Lisp_Object Qone_dimensional, Qtwo_dimensional, Qx_coverage_instantiator; |
| 3659 | 2038 |
| 4187 | 2039 DEFUN ("specifier-tag-one-dimensional-p", |
| 2040 Fspecifier_tag_one_dimensional_p, | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2041 1, 1, 0, /* |
| 3659 | 2042 Return non-nil if (charset-dimension CHARSET) is 1. |
| 2043 | |
| 2044 Used by the X11 platform font code; see `define-specifier-tag'. You | |
| 2045 shouldn't ever need to call this yourself. | |
| 2046 */ | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2047 (charset)) |
| 3659 | 2048 { |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2049 CHECK_CHARSET (charset); |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2050 return (1 == XCHARSET_DIMENSION (charset)) ? Qt : Qnil; |
| 3659 | 2051 } |
| 2052 | |
| 4187 | 2053 DEFUN ("specifier-tag-two-dimensional-p", |
| 2054 Fspecifier_tag_two_dimensional_p, | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2055 1, 1, 0, /* |
| 3659 | 2056 Return non-nil if (charset-dimension CHARSET) is 2. |
| 2057 | |
| 2058 Used by the X11 platform font code; see `define-specifier-tag'. You | |
| 2059 shouldn't ever need to call this yourself. | |
| 2060 */ | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2061 (charset)) |
| 3659 | 2062 { |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2063 CHECK_CHARSET (charset); |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2064 return (2 == XCHARSET_DIMENSION (charset)) ? Qt : Qnil; |
| 3659 | 2065 } |
| 2066 | |
| 4187 | 2067 DEFUN ("specifier-tag-final-stage-p", |
| 2068 Fspecifier_tag_final_stage_p, | |
| 3659 | 2069 2, 2, 0, /* |
| 2070 Return non-nil if STAGE is 'final. | |
| 2071 | |
| 2072 Used by the X11 platform font code for giving fallbacks; see | |
| 4187 | 2073 `define-specifier-tag'. You shouldn't ever need to call this. |
| 3659 | 2074 */ |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2075 (UNUSED (charset), stage)) |
| 3659 | 2076 { |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2077 return EQ (stage, Qfinal) ? Qt : Qnil; |
| 3659 | 2078 } |
| 2079 | |
| 4187 | 2080 DEFUN ("specifier-tag-initial-stage-p", |
| 2081 Fspecifier_tag_initial_stage_p, | |
| 3659 | 2082 2, 2, 0, /* |
| 2083 Return non-nil if STAGE is 'initial. | |
| 2084 | |
| 2085 Used by the X11 platform font code for giving fallbacks; see | |
| 4187 | 2086 `define-specifier-tag'. You shouldn't ever need to call this. |
| 3659 | 2087 */ |
| 2088 (UNUSED(charset), stage)) | |
| 2089 { | |
| 2090 return EQ(stage, Qinitial) ? Qt : Qnil; | |
| 2091 } | |
| 2092 | |
| 4187 | 2093 DEFUN ("specifier-tag-encode-as-utf-8-p", |
| 2094 Fspecifier_tag_encode_as_utf_8_p, | |
| 3659 | 2095 2, 2, 0, /* |
| 2096 Return t if and only if (charset-property CHARSET 'encode-as-utf-8)). | |
| 2097 | |
| 2098 Used by the X11 platform font code; see `define-specifier-tag'. You | |
| 2099 shouldn't ever need to call this. | |
| 2100 */ | |
| 2101 (charset, UNUSED(stage))) | |
| 2102 { | |
| 2103 /* Used to check that the stage was initial too. */ | |
| 2104 CHECK_CHARSET(charset); | |
| 2105 return XCHARSET_ENCODE_AS_UTF_8(charset) ? Qt : Qnil; | |
| 2106 } | |
| 2107 | |
| 2108 #endif /* MULE */ | |
| 2109 | |
| 428 | 2110 |
| 2111 void | |
|
5157
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5128
diff
changeset
|
2112 face_objects_create (void) |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5128
diff
changeset
|
2113 { |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5128
diff
changeset
|
2114 OBJECT_HAS_METHOD (face, getprop); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5128
diff
changeset
|
2115 OBJECT_HAS_METHOD (face, putprop); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5128
diff
changeset
|
2116 OBJECT_HAS_METHOD (face, remprop); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5128
diff
changeset
|
2117 OBJECT_HAS_METHOD (face, plist); |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5128
diff
changeset
|
2118 } |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5128
diff
changeset
|
2119 |
|
1fae11d56ad2
redo memory-usage mechanism, add way of dynamically initializing Lisp objects
Ben Wing <ben@xemacs.org>
parents:
5128
diff
changeset
|
2120 void |
| 428 | 2121 syms_of_faces (void) |
| 2122 { | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
2123 INIT_LISP_OBJECT (face); |
| 442 | 2124 |
| 440 | 2125 /* Qdefault, Qwidget, Qleft_margin, Qright_margin defined in general.c */ |
| 563 | 2126 DEFSYMBOL (Qmodeline); |
| 2127 DEFSYMBOL (Qgui_element); | |
| 2128 DEFSYMBOL (Qtext_cursor); | |
| 2129 DEFSYMBOL (Qvertical_divider); | |
| 428 | 2130 |
| 2131 DEFSUBR (Ffacep); | |
| 2132 DEFSUBR (Ffind_face); | |
| 2133 DEFSUBR (Fget_face); | |
| 2134 DEFSUBR (Fface_name); | |
| 2135 DEFSUBR (Fbuilt_in_face_specifiers); | |
| 2136 DEFSUBR (Fface_list); | |
| 2137 DEFSUBR (Fmake_face); | |
| 2138 DEFSUBR (Fcopy_face); | |
| 2139 | |
| 3659 | 2140 #ifdef MULE |
| 2141 DEFSYMBOL (Qone_dimensional); | |
| 2142 DEFSYMBOL (Qtwo_dimensional); | |
| 3918 | 2143 DEFSYMBOL (Qx_coverage_instantiator); |
| 2144 | |
| 3659 | 2145 /* I would much prefer these were in Lisp. */ |
| 2146 DEFSUBR (Fspecifier_tag_one_dimensional_p); | |
| 2147 DEFSUBR (Fspecifier_tag_two_dimensional_p); | |
| 2148 DEFSUBR (Fspecifier_tag_initial_stage_p); | |
| 2149 DEFSUBR (Fspecifier_tag_final_stage_p); | |
| 2150 DEFSUBR (Fspecifier_tag_encode_as_utf_8_p); | |
| 2151 #endif /* MULE */ | |
| 2152 | |
| 563 | 2153 DEFSYMBOL (Qfacep); |
| 2154 DEFSYMBOL (Qforeground); | |
| 2155 DEFSYMBOL (Qbackground); | |
| 428 | 2156 /* Qfont defined in general.c */ |
| 563 | 2157 DEFSYMBOL (Qdisplay_table); |
| 2158 DEFSYMBOL (Qbackground_pixmap); | |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
2159 DEFSYMBOL (Qbackground_placement); |
| 563 | 2160 DEFSYMBOL (Qunderline); |
| 2161 DEFSYMBOL (Qstrikethru); | |
| 428 | 2162 /* Qhighlight, Qreverse defined in general.c */ |
| 563 | 2163 DEFSYMBOL (Qdim); |
| 2164 DEFSYMBOL (Qblinking); | |
| 428 | 2165 |
| 2865 | 2166 DEFSYMBOL (Qface_alias); |
| 2867 | 2167 DEFERROR_STANDARD (Qcyclic_face_alias, Qinvalid_state); |
| 2865 | 2168 |
| 563 | 2169 DEFSYMBOL (Qinit_face_from_resources); |
| 2170 DEFSYMBOL (Qinit_global_faces); | |
| 2171 DEFSYMBOL (Qinit_device_faces); | |
| 2172 DEFSYMBOL (Qinit_frame_faces); | |
| 428 | 2173 } |
| 2174 | |
| 2175 void | |
| 2176 structure_type_create_faces (void) | |
| 2177 { | |
| 2178 struct structure_type *st; | |
| 2179 | |
| 2180 st = define_structure_type (Qface, face_validate, face_instantiate); | |
| 2181 | |
| 2182 define_structure_type_keyword (st, Qname, face_name_validate); | |
| 2183 } | |
| 2184 | |
| 2185 void | |
| 2186 vars_of_faces (void) | |
| 2187 { | |
| 2188 staticpro (&Vpermanent_faces_cache); | |
| 771 | 2189 Vpermanent_faces_cache = |
| 2190 make_lisp_hash_table (10, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); | |
| 428 | 2191 staticpro (&Vtemporary_faces_cache); |
| 771 | 2192 Vtemporary_faces_cache = |
| 2193 make_lisp_hash_table (0, HASH_TABLE_WEAK, HASH_TABLE_EQ); | |
| 428 | 2194 |
| 2195 staticpro (&Vdefault_face); | |
| 2196 Vdefault_face = Qnil; | |
| 2197 staticpro (&Vgui_element_face); | |
| 2198 Vgui_element_face = Qnil; | |
| 2199 staticpro (&Vwidget_face); | |
| 2200 Vwidget_face = Qnil; | |
| 2201 staticpro (&Vmodeline_face); | |
| 2202 Vmodeline_face = Qnil; | |
| 2203 staticpro (&Vtoolbar_face); | |
| 2204 Vtoolbar_face = Qnil; | |
| 2205 | |
| 2206 staticpro (&Vvertical_divider_face); | |
| 2207 Vvertical_divider_face = Qnil; | |
| 2208 staticpro (&Vleft_margin_face); | |
| 2209 Vleft_margin_face = Qnil; | |
| 2210 staticpro (&Vright_margin_face); | |
| 2211 Vright_margin_face = Qnil; | |
| 2212 staticpro (&Vtext_cursor_face); | |
| 2213 Vtext_cursor_face = Qnil; | |
| 2214 staticpro (&Vpointer_face); | |
| 2215 Vpointer_face = Qnil; | |
| 2216 | |
| 3659 | 2217 #ifdef DEBUG_XEMACS |
| 2218 DEFVAR_INT ("debug-x-faces", &debug_x_faces /* | |
| 2219 If non-zero, display debug information about X faces | |
| 2220 */ ); | |
| 2221 debug_x_faces = 0; | |
| 2222 #endif | |
| 2223 | |
| 428 | 2224 { |
| 2225 Lisp_Object syms[20]; | |
| 2226 int n = 0; | |
| 2227 | |
| 2228 syms[n++] = Qforeground; | |
| 2229 syms[n++] = Qbackground; | |
| 2230 syms[n++] = Qfont; | |
| 2231 syms[n++] = Qdisplay_table; | |
| 2232 syms[n++] = Qbackground_pixmap; | |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
2233 syms[n++] = Qbackground_placement; |
| 428 | 2234 syms[n++] = Qunderline; |
| 2235 syms[n++] = Qstrikethru; | |
| 2236 syms[n++] = Qhighlight; | |
| 2237 syms[n++] = Qdim; | |
| 2238 syms[n++] = Qblinking; | |
| 2239 syms[n++] = Qreverse; | |
| 2240 | |
| 2241 Vbuilt_in_face_specifiers = Flist (n, syms); | |
| 2242 staticpro (&Vbuilt_in_face_specifiers); | |
| 2243 } | |
| 2244 } | |
| 2245 | |
| 2246 void | |
| 2247 complex_vars_of_faces (void) | |
| 2248 { | |
| 2249 /* Create the default face now so we know what it is immediately. */ | |
| 2250 | |
| 2251 Vdefault_face = Qnil; /* so that Fmake_face() doesn't set up a bogus | |
| 2252 default value */ | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4862
diff
changeset
|
2253 Vdefault_face = Fmake_face (Qdefault, build_defer_string ("default face"), |
| 428 | 2254 Qnil); |
| 2255 | |
| 2256 /* Provide some last-resort fallbacks to avoid utter fuckage if | |
| 2257 someone provides invalid values for the global specifications. */ | |
| 2258 | |
| 2259 { | |
| 2260 Lisp_Object fg_fb = Qnil, bg_fb = Qnil; | |
| 2261 | |
| 462 | 2262 #ifdef HAVE_GTK |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4862
diff
changeset
|
2263 fg_fb = acons (list1 (Qgtk), build_ascstring ("black"), fg_fb); |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4862
diff
changeset
|
2264 bg_fb = acons (list1 (Qgtk), build_ascstring ("white"), bg_fb); |
| 462 | 2265 #endif |
| 428 | 2266 #ifdef HAVE_X_WINDOWS |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4862
diff
changeset
|
2267 fg_fb = acons (list1 (Qx), build_ascstring ("black"), fg_fb); |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4862
diff
changeset
|
2268 bg_fb = acons (list1 (Qx), build_ascstring ("gray80"), bg_fb); |
| 428 | 2269 #endif |
| 2270 #ifdef HAVE_TTY | |
| 2271 fg_fb = acons (list1 (Qtty), Fvector (0, 0), fg_fb); | |
| 2272 bg_fb = acons (list1 (Qtty), Fvector (0, 0), bg_fb); | |
| 2273 #endif | |
| 2274 #ifdef HAVE_MS_WINDOWS | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4862
diff
changeset
|
2275 fg_fb = acons (list1 (Qmsprinter), build_ascstring ("black"), fg_fb); |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4862
diff
changeset
|
2276 bg_fb = acons (list1 (Qmsprinter), build_ascstring ("white"), bg_fb); |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4862
diff
changeset
|
2277 fg_fb = acons (list1 (Qmswindows), build_ascstring ("black"), fg_fb); |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4862
diff
changeset
|
2278 bg_fb = acons (list1 (Qmswindows), build_ascstring ("white"), bg_fb); |
| 428 | 2279 #endif |
| 2280 set_specifier_fallback (Fget (Vdefault_face, Qforeground, Qnil), fg_fb); | |
| 2281 set_specifier_fallback (Fget (Vdefault_face, Qbackground, Qnil), bg_fb); | |
| 2282 } | |
| 2283 | |
| 2284 { | |
| 2285 Lisp_Object inst_list = Qnil; | |
| 462 | 2286 |
| 872 | 2287 #if defined (HAVE_X_WINDOWS) || defined (HAVE_GTK) |
| 2865 | 2288 |
| 3659 | 2289 #ifdef HAVE_GTK |
| 2290 Lisp_Object device_symbol = Qgtk; | |
| 2291 #else | |
| 2292 Lisp_Object device_symbol = Qx; | |
| 2293 #endif | |
| 2294 | |
|
4916
a6c778975d7d
split USE_XFT into HAVE_XFT/USE_XFT
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
2295 #if defined (HAVE_XFT) || defined (MULE) |
| 3802 | 2296 const Ascbyte **fontptr; |
| 3659 | 2297 |
| 2367 | 2298 const Ascbyte *fonts[] = |
| 428 | 2299 { |
|
4916
a6c778975d7d
split USE_XFT into HAVE_XFT/USE_XFT
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
2300 #ifdef HAVE_XFT |
| 3094 | 2301 /************** Xft fonts *************/ |
| 2302 | |
| 2303 /* Note that fontconfig can search for several font families in one | |
| 2304 call. We should use this facility. */ | |
| 3659 | 2305 "Monospace-12", |
| 3094 | 2306 /* do we need to worry about non-Latin characters for monospace? |
| 4187 | 2307 No, at least in Debian's implementation of Xft. |
| 3094 | 2308 We should recommend that "gothic" and "mincho" aliases be created? */ |
| 3659 | 2309 "Sazanami Mincho-12", |
| 2310 /* Japanese #### add encoding info? */ | |
| 4187 | 2311 /* Arphic for Chinese? */ |
| 2312 /* Korean */ | |
| 3094 | 2313 #else |
| 3659 | 2314 /* The default Japanese fonts installed with XFree86 4.0 use this |
| 2315 point size, and the -misc-fixed fonts (which look really bad with | |
| 2316 Han characters) don't. We need to prefer the former. */ | |
| 2317 "-*-*-medium-r-*-*-*-150-*-*-c-*-*-*", | |
| 2318 /* And the Chinese ones, maddeningly, use this one. (But on 4.0, while | |
| 2319 XListFonts returns them, XLoadQueryFont on the fully-specified XLFD | |
| 2320 corresponding to one of them fails!) */ | |
| 2321 "-*-*-medium-r-*-*-*-160-*-*-c-*-*-*", | |
| 2322 "-*-*-medium-r-*-*-*-170-*-*-c-*-*-*", | |
| 3094 | 2323 #endif |
| 428 | 2324 }; |
|
4916
a6c778975d7d
split USE_XFT into HAVE_XFT/USE_XFT
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
2325 #endif /* defined (HAVE_XFT) || defined (MULE) */ |
| 3802 | 2326 |
| 2327 #ifdef MULE | |
| 428 | 2328 |
| 3659 | 2329 /* Define some specifier tags for classes of character sets. Combining |
| 2330 these allows for distinct fallback fonts for distinct dimensions of | |
| 2331 character sets and stages. */ | |
| 2332 | |
| 2333 define_specifier_tag(Qtwo_dimensional, Qnil, | |
| 2334 intern ("specifier-tag-two-dimensional-p")); | |
| 2335 | |
| 2336 define_specifier_tag(Qone_dimensional, Qnil, | |
| 2337 intern ("specifier-tag-one-dimensional-p")); | |
| 2338 | |
| 4187 | 2339 define_specifier_tag(Qinitial, Qnil, |
| 3659 | 2340 intern ("specifier-tag-initial-stage-p")); |
| 2341 | |
| 4187 | 2342 define_specifier_tag(Qfinal, Qnil, |
| 3659 | 2343 intern ("specifier-tag-final-stage-p")); |
| 2344 | |
| 2345 define_specifier_tag (Qencode_as_utf_8, Qnil, | |
| 2346 intern("specifier-tag-encode-as-utf-8-p")); | |
| 3918 | 2347 |
| 2348 /* This tag is used to group those instantiators made available in the | |
| 2349 fallback for the sake of coverage of obscure characters, notably | |
| 2350 Markus Kuhn's misc-fixed fonts. They will be copied from the fallback | |
| 2351 when the default face is determined from X resources at startup. */ | |
| 2352 define_specifier_tag (Qx_coverage_instantiator, Qnil, Qnil); | |
| 2353 | |
| 3659 | 2354 #endif /* MULE */ |
| 2355 | |
|
4916
a6c778975d7d
split USE_XFT into HAVE_XFT/USE_XFT
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
2356 #ifdef HAVE_XFT |
| 3747 | 2357 for (fontptr = fonts + countof(fonts) - 1; fontptr >= fonts; fontptr--) |
| 2358 inst_list = Fcons (Fcons (list1 (device_symbol), | |
|
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4952
diff
changeset
|
2359 build_cistring (*fontptr)), |
| 3747 | 2360 inst_list); |
| 2361 | |
|
4916
a6c778975d7d
split USE_XFT into HAVE_XFT/USE_XFT
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
2362 #else /* !HAVE_XFT */ |
| 3659 | 2363 inst_list = |
| 4187 | 2364 Fcons |
| 3659 | 2365 (Fcons |
| 4187 | 2366 (list1 (device_symbol), |
|
4766
32b358a240b0
Avoid calling Xft if not built in.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4759
diff
changeset
|
2367 /* grrr. This really does need to be "*", not an XLFD. |
|
32b358a240b0
Avoid calling Xft if not built in.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4759
diff
changeset
|
2368 An unspecified XLFD won't pick up stuff like 10x20. */ |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4862
diff
changeset
|
2369 build_ascstring ("*")), |
| 3659 | 2370 inst_list); |
| 4187 | 2371 #ifdef MULE |
| 3659 | 2372 |
| 2373 /* For Han characters and Ethiopic, we want the misc-fixed font used to | |
| 2374 be distinct from that for alphabetic scripts, because the font | |
| 2375 specified below is distractingly ugly when used for Han characters | |
| 2376 (this is slightly less so) and because its coverage isn't up to | |
| 2377 handling them (well, chiefly, it's not up to handling Ethiopic--we do | |
| 2378 have charset-specific fallbacks for the East Asian charsets.) */ | |
| 4187 | 2379 inst_list = |
| 3659 | 2380 Fcons |
| 2381 (Fcons | |
| 4187 | 2382 (list4(device_symbol, Qtwo_dimensional, Qfinal, Qx_coverage_instantiator), |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4862
diff
changeset
|
2383 build_ascstring |
| 3659 | 2384 ("-misc-fixed-medium-r-normal--15-140-75-75-c-90-iso10646-1")), |
| 2385 inst_list); | |
| 2386 | |
| 2387 /* Use Markus Kuhn's version of misc-fixed as the font for the font for | |
| 2388 when a given charset's registries can't be found and redisplay for | |
| 2389 that charset falls back to iso10646-1. */ | |
| 428 | 2390 |
| 4187 | 2391 inst_list = |
| 3659 | 2392 Fcons |
| 2393 (Fcons | |
| 4187 | 2394 (list4(device_symbol, Qone_dimensional, Qfinal, Qx_coverage_instantiator), |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4862
diff
changeset
|
2395 build_ascstring |
| 4187 | 2396 ("-misc-fixed-medium-r-semicondensed--13-120-75-75-c-60-iso10646-1")), |
| 3659 | 2397 inst_list); |
| 2398 | |
| 462 | 2399 for (fontptr = fonts + countof(fonts) - 1; fontptr >= fonts; fontptr--) |
| 4187 | 2400 inst_list = Fcons (Fcons (list3 (device_symbol, |
| 3659 | 2401 Qtwo_dimensional, Qinitial), |
|
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
4952
diff
changeset
|
2402 build_cistring (*fontptr)), |
| 462 | 2403 inst_list); |
| 3659 | 2404 |
| 2405 /* We need to set the font for the JIT-ucs-charsets separately from the | |
| 2406 final stage, since otherwise it picks up the two-dimensional | |
| 2407 specification (see specifier-tag-two-dimensional-initial-stage-p | |
| 2408 above). They also use Markus Kuhn's ISO 10646-1 fixed fonts for | |
| 2409 redisplay. */ | |
| 2410 | |
| 4187 | 2411 inst_list = |
| 3659 | 2412 Fcons |
| 2413 (Fcons | |
| 4187 | 2414 (list4(device_symbol, Qencode_as_utf_8, Qinitial, Qx_coverage_instantiator), |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4862
diff
changeset
|
2415 build_ascstring |
| 4187 | 2416 ("-misc-fixed-medium-r-semicondensed--13-120-75-75-c-60-iso10646-1")), |
| 3659 | 2417 inst_list); |
| 2418 | |
| 2419 #endif /* MULE */ | |
| 2420 | |
| 2421 /* Needed to make sure that charsets with non-specified fonts don't | |
| 2422 use bold and oblique first if medium and regular are available. */ | |
| 2423 inst_list = | |
| 4187 | 2424 Fcons |
| 3659 | 2425 (Fcons |
| 4187 | 2426 (list1 (device_symbol), |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4862
diff
changeset
|
2427 build_ascstring ("-*-*-medium-r-*-*-*-120-*-*-c-*-*-*")), |
| 3659 | 2428 inst_list); |
| 2429 | |
| 2430 /* With a Cygwin XFree86 install, this returns the best (clearest, | |
| 2431 most readable) font I can find when scaling of bitmap fonts is | |
| 2432 turned on, as it is by default. (WHO IN THE NAME OF CHRIST THOUGHT | |
| 2433 THAT WAS A GOOD IDEA?!?!) The other fonts that used to be specified | |
| 2434 here gave horrendous results. */ | |
| 2435 | |
| 2436 inst_list = | |
| 4187 | 2437 Fcons |
| 3659 | 2438 (Fcons |
| 4187 | 2439 (list1 (device_symbol), |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4862
diff
changeset
|
2440 build_ascstring ("-*-lucidatypewriter-medium-r-*-*-*-120-*-*-*-*-*-*")), |
| 3659 | 2441 inst_list); |
| 2442 | |
|
4916
a6c778975d7d
split USE_XFT into HAVE_XFT/USE_XFT
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
2443 #endif /* !HAVE_XFT */ |
| 3747 | 2444 |
| 462 | 2445 #endif /* HAVE_X_WINDOWS || HAVE_GTK */ |
| 2446 | |
| 428 | 2447 #ifdef HAVE_TTY |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4862
diff
changeset
|
2448 inst_list = Fcons (Fcons (list1 (Qtty), build_ascstring ("normal")), |
| 428 | 2449 inst_list); |
| 2450 #endif /* HAVE_TTY */ | |
| 440 | 2451 |
| 771 | 2452 #ifdef HAVE_MS_WINDOWS |
| 2453 { | |
| 2367 | 2454 const Ascbyte *mswfonts[] = |
| 4187 | 2455 { |
| 2456 "Courier New:Regular:10::", | |
| 2457 "Courier:Regular:10::", | |
| 2458 ":Regular:10::" | |
| 2459 }; | |
| 2367 | 2460 const Ascbyte **mswfontptr; |
| 2865 | 2461 |
| 771 | 2462 for (mswfontptr = mswfonts + countof (mswfonts) - 1; |
| 2463 mswfontptr >= mswfonts; mswfontptr--) | |
| 4187 | 2464 { |
| 2465 /* display device */ | |
| 2466 inst_list = Fcons (Fcons (list1 (Qmswindows), | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4862
diff
changeset
|
2467 build_ascstring (*mswfontptr)), |
| 4187 | 2468 inst_list); |
| 2469 /* printer device */ | |
| 2470 inst_list = Fcons (Fcons (list1 (Qmsprinter), | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4862
diff
changeset
|
2471 build_ascstring (*mswfontptr)), |
| 4187 | 2472 inst_list); |
| 2473 } | |
| 793 | 2474 /* Use Lucida Console rather than Courier New if it exists -- the |
| 4187 | 2475 line spacing is much less, so many more lines fit with the same |
| 2476 size font. (And it's specifically designed for screens.) */ | |
| 2865 | 2477 inst_list = Fcons (Fcons (list1 (Qmswindows), |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4862
diff
changeset
|
2478 build_ascstring ("Lucida Console:Regular:10::")), |
| 793 | 2479 inst_list); |
| 771 | 2480 } |
| 428 | 2481 #endif /* HAVE_MS_WINDOWS */ |
| 771 | 2482 |
| 428 | 2483 set_specifier_fallback (Fget (Vdefault_face, Qfont, Qnil), inst_list); |
| 2484 } | |
| 2485 | |
| 2486 set_specifier_fallback (Fget (Vdefault_face, Qunderline, Qnil), | |
| 2487 list1 (Fcons (Qnil, Qnil))); | |
| 2488 set_specifier_fallback (Fget (Vdefault_face, Qstrikethru, Qnil), | |
| 2489 list1 (Fcons (Qnil, Qnil))); | |
| 2490 set_specifier_fallback (Fget (Vdefault_face, Qhighlight, Qnil), | |
| 2491 list1 (Fcons (Qnil, Qnil))); | |
| 2492 set_specifier_fallback (Fget (Vdefault_face, Qdim, Qnil), | |
| 2493 list1 (Fcons (Qnil, Qnil))); | |
| 2494 set_specifier_fallback (Fget (Vdefault_face, Qblinking, Qnil), | |
| 2495 list1 (Fcons (Qnil, Qnil))); | |
| 2496 set_specifier_fallback (Fget (Vdefault_face, Qreverse, Qnil), | |
| 2497 list1 (Fcons (Qnil, Qnil))); | |
| 2498 | |
| 2499 /* gui-element is the parent face of all gui elements such as | |
| 2500 modeline, vertical divider and toolbar. */ | |
| 2501 Vgui_element_face = Fmake_face (Qgui_element, | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4862
diff
changeset
|
2502 build_defer_string ("gui element face"), |
| 428 | 2503 Qnil); |
| 2504 | |
| 2505 /* Provide some last-resort fallbacks for gui-element face which | |
| 2506 mustn't default to default. */ | |
| 2507 { | |
| 2508 Lisp_Object fg_fb = Qnil, bg_fb = Qnil; | |
| 2509 | |
| 3094 | 2510 /* #### gui-element face doesn't have a font property? |
| 2511 But it gets referred to later! */ | |
| 462 | 2512 #ifdef HAVE_GTK |
| 2513 /* We need to put something in there, or error checking gets | |
| 2514 #%!@#ed up before the styles are set, which override the | |
| 2515 fallbacks. */ | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4862
diff
changeset
|
2516 fg_fb = acons (list1 (Qgtk), build_ascstring ("black"), fg_fb); |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4862
diff
changeset
|
2517 bg_fb = acons (list1 (Qgtk), build_ascstring ("Gray80"), bg_fb); |
| 462 | 2518 #endif |
| 428 | 2519 #ifdef HAVE_X_WINDOWS |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4862
diff
changeset
|
2520 fg_fb = acons (list1 (Qx), build_ascstring ("black"), fg_fb); |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4862
diff
changeset
|
2521 bg_fb = acons (list1 (Qx), build_ascstring ("Gray80"), bg_fb); |
| 428 | 2522 #endif |
| 2523 #ifdef HAVE_TTY | |
| 2524 fg_fb = acons (list1 (Qtty), Fvector (0, 0), fg_fb); | |
| 2525 bg_fb = acons (list1 (Qtty), Fvector (0, 0), bg_fb); | |
| 2526 #endif | |
| 2527 #ifdef HAVE_MS_WINDOWS | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4862
diff
changeset
|
2528 fg_fb = acons (list1 (Qmsprinter), build_ascstring ("black"), fg_fb); |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4862
diff
changeset
|
2529 bg_fb = acons (list1 (Qmsprinter), build_ascstring ("white"), bg_fb); |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4862
diff
changeset
|
2530 fg_fb = acons (list1 (Qmswindows), build_ascstring ("black"), fg_fb); |
|
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4862
diff
changeset
|
2531 bg_fb = acons (list1 (Qmswindows), build_ascstring ("Gray75"), bg_fb); |
| 428 | 2532 #endif |
| 2533 set_specifier_fallback (Fget (Vgui_element_face, Qforeground, Qnil), fg_fb); | |
| 2534 set_specifier_fallback (Fget (Vgui_element_face, Qbackground, Qnil), bg_fb); | |
| 2535 } | |
| 2536 | |
| 2537 /* Now create the other faces that redisplay needs to refer to | |
| 2538 directly. We could create them in Lisp but it's simpler this | |
| 2539 way since we need to get them anyway. */ | |
| 2540 | |
| 2541 /* modeline is gui element. */ | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4862
diff
changeset
|
2542 Vmodeline_face = Fmake_face (Qmodeline, build_defer_string ("modeline face"), |
| 428 | 2543 Qnil); |
| 2544 | |
| 2545 set_specifier_fallback (Fget (Vmodeline_face, Qforeground, Qunbound), | |
| 2546 Fget (Vgui_element_face, Qforeground, Qunbound)); | |
| 2547 set_specifier_fallback (Fget (Vmodeline_face, Qbackground, Qunbound), | |
| 2548 Fget (Vgui_element_face, Qbackground, Qunbound)); | |
| 2549 set_specifier_fallback (Fget (Vmodeline_face, Qbackground_pixmap, Qnil), | |
| 2550 Fget (Vgui_element_face, Qbackground_pixmap, | |
| 2551 Qunbound)); | |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
2552 set_specifier_fallback (Fget (Vmodeline_face, Qbackground_placement, Qnil), |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
2553 Fget (Vgui_element_face, Qbackground_placement, |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
2554 Qunbound)); |
| 428 | 2555 |
| 2556 /* toolbar is another gui element */ | |
| 2557 Vtoolbar_face = Fmake_face (Qtoolbar, | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4862
diff
changeset
|
2558 build_defer_string ("toolbar face"), |
| 428 | 2559 Qnil); |
| 2560 set_specifier_fallback (Fget (Vtoolbar_face, Qforeground, Qunbound), | |
| 2561 Fget (Vgui_element_face, Qforeground, Qunbound)); | |
| 2562 set_specifier_fallback (Fget (Vtoolbar_face, Qbackground, Qunbound), | |
| 2563 Fget (Vgui_element_face, Qbackground, Qunbound)); | |
| 2564 set_specifier_fallback (Fget (Vtoolbar_face, Qbackground_pixmap, Qnil), | |
| 2565 Fget (Vgui_element_face, Qbackground_pixmap, | |
| 2566 Qunbound)); | |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
2567 set_specifier_fallback (Fget (Vtoolbar_face, Qbackground_placement, Qnil), |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
2568 Fget (Vgui_element_face, Qbackground_placement, |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
2569 Qunbound)); |
| 428 | 2570 |
| 2571 /* vertical divider is another gui element */ | |
| 2572 Vvertical_divider_face = Fmake_face (Qvertical_divider, | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4862
diff
changeset
|
2573 build_defer_string ("vertical divider face"), |
| 428 | 2574 Qnil); |
| 2575 | |
| 2576 set_specifier_fallback (Fget (Vvertical_divider_face, Qforeground, Qunbound), | |
| 2577 Fget (Vgui_element_face, Qforeground, Qunbound)); | |
| 2578 set_specifier_fallback (Fget (Vvertical_divider_face, Qbackground, Qunbound), | |
| 2579 Fget (Vgui_element_face, Qbackground, Qunbound)); | |
| 2580 set_specifier_fallback (Fget (Vvertical_divider_face, Qbackground_pixmap, | |
| 2581 Qunbound), | |
| 2582 Fget (Vgui_element_face, Qbackground_pixmap, | |
| 2583 Qunbound)); | |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
2584 set_specifier_fallback (Fget (Vvertical_divider_face, Qbackground_placement, |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
2585 Qnil), |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
2586 Fget (Vgui_element_face, Qbackground_placement, |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5047
diff
changeset
|
2587 Qunbound)); |
| 428 | 2588 |
| 2589 /* widget is another gui element */ | |
| 2590 Vwidget_face = Fmake_face (Qwidget, | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4862
diff
changeset
|
2591 build_defer_string ("widget face"), |
| 428 | 2592 Qnil); |
| 3094 | 2593 /* #### weird ... the gui-element face doesn't have its own font yet */ |
| 442 | 2594 set_specifier_fallback (Fget (Vwidget_face, Qfont, Qunbound), |
| 2595 Fget (Vgui_element_face, Qfont, Qunbound)); | |
| 428 | 2596 set_specifier_fallback (Fget (Vwidget_face, Qforeground, Qunbound), |
| 2597 Fget (Vgui_element_face, Qforeground, Qunbound)); | |
| 2598 set_specifier_fallback (Fget (Vwidget_face, Qbackground, Qunbound), | |
| 2599 Fget (Vgui_element_face, Qbackground, Qunbound)); | |
| 442 | 2600 /* We don't want widgets to have a default background pixmap. */ |
| 428 | 2601 |
| 2602 Vleft_margin_face = Fmake_face (Qleft_margin, | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4862
diff
changeset
|
2603 build_defer_string ("left margin face"), |
| 428 | 2604 Qnil); |
| 2605 Vright_margin_face = Fmake_face (Qright_margin, | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4862
diff
changeset
|
2606 build_defer_string ("right margin face"), |
| 428 | 2607 Qnil); |
| 2608 Vtext_cursor_face = Fmake_face (Qtext_cursor, | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4862
diff
changeset
|
2609 build_defer_string ("face for text cursor"), |
| 428 | 2610 Qnil); |
| 2611 Vpointer_face = | |
| 2612 Fmake_face (Qpointer, | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4862
diff
changeset
|
2613 build_defer_string |
| 428 | 2614 ("face for foreground/background colors of mouse pointer"), |
| 2615 Qnil); | |
| 2616 } |