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