Mercurial > hg > xemacs-beta
annotate src/objects.c @ 5142:f965e31a35f0
reduce lcrecord headers to 2 words, rename printing_unreadable_object
-------------------- ChangeLog entries follow: --------------------
man/ChangeLog addition:
2010-03-13 Ben Wing <ben@xemacs.org>
* internals/internals.texi (Working with Lisp Objects):
* internals/internals.texi (Writing Macros):
* internals/internals.texi (lrecords):
More rewriting to correspond with changes from
*LRECORD* to *LISP_OBJECT*.
modules/ChangeLog addition:
2010-03-13 Ben Wing <ben@xemacs.org>
* postgresql/postgresql.c (print_pgconn):
* postgresql/postgresql.c (print_pgresult):
printing_unreadable_object -> printing_unreadable_object_fmt.
2010-03-13 Ben Wing <ben@xemacs.org>
* ldap/eldap.c (print_ldap):
printing_unreadable_object -> printing_unreadable_object_fmt.
src/ChangeLog addition:
2010-03-13 Ben Wing <ben@xemacs.org>
* alloc.c (alloc_sized_lrecord_1):
* alloc.c (alloc_sized_lrecord_array):
* alloc.c (old_alloc_sized_lcrecord):
* alloc.c (disksave_object_finalization_1):
* alloc.c (mark_lcrecord_list):
* alloc.c (alloc_managed_lcrecord):
* alloc.c (free_managed_lcrecord):
* alloc.c (tick_lcrecord_stats):
* alloc.c (sweep_lcrecords_1):
* buffer.c (print_buffer):
* buffer.c (DEFVAR_BUFFER_LOCAL_1):
* casetab.c:
* casetab.c (print_case_table):
* console.c (print_console):
* console.c (DEFVAR_CONSOLE_LOCAL_1):
* data.c (print_weak_list):
* data.c (print_weak_box):
* data.c (print_ephemeron):
* data.c (ephemeron_equal):
* 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_subr):
* eval.c (print_multiple_value):
* event-stream.c (event_stream_resignal_wakeup):
* events.c (clear_event_resource):
* events.c (zero_event):
* events.c (print_event):
* extents.c:
* extents.c (print_extent):
* file-coding.c (print_coding_system):
* font-mgr.c:
* font-mgr.c (Ffc_init):
* frame.c:
* frame.c (print_frame):
* gc.c:
* gc.c (GC_CHECK_NOT_FREE):
* glyphs.c:
* glyphs.c (print_image_instance):
* glyphs.c (print_glyph):
* gui.c (print_gui_item):
* gui.c (copy_gui_item):
* keymap.c (print_keymap):
* keymap.c (MARKED_SLOT):
* lisp.h:
* lisp.h (struct Lisp_String):
* lisp.h (DEFUN):
* lisp.h (DEFUN_NORETURN):
* lrecord.h:
* lrecord.h (NORMAL_LISP_OBJECT_UID):
* lrecord.h (struct lrecord_header):
* lrecord.h (set_lheader_implementation):
* lrecord.h (struct old_lcrecord_header):
* lrecord.h (struct free_lcrecord_header):
* marker.c (print_marker):
* mule-charset.c:
* mule-charset.c (print_charset):
* objects.c (print_color_instance):
* objects.c (print_font_instance):
* objects.c (finalize_font_instance):
* print.c (print_cons):
* print.c (printing_unreadable_object_fmt):
* print.c (printing_unreadable_lisp_object):
* print.c (external_object_printer):
* print.c (internal_object_printer):
* print.c (debug_p4):
* print.c (ext_print_begin):
* process.c (print_process):
* rangetab.c (print_range_table):
* rangetab.c (range_table_equal):
* scrollbar.c (free_scrollbar_instance):
* specifier.c (print_specifier):
* specifier.c (finalize_specifier):
* symbols.c (guts_of_unbound_marker):
* symeval.h:
* symeval.h (DEFVAR_SYMVAL_FWD):
* tooltalk.c:
* tooltalk.c (print_tooltalk_message):
* tooltalk.c (print_tooltalk_pattern):
* ui-gtk.c (ffi_object_printer):
* ui-gtk.c (emacs_gtk_object_printer):
* ui-gtk.c (emacs_gtk_boxed_printer):
* window.c (print_window):
* window.c (free_window_mirror):
* window.c (debug_print_window):
* xemacs.def.in.in:
(1) printing_unreadable_object -> printing_unreadable_object_fmt.
(2) printing_unreadable_lcrecord -> printing_unreadable_lisp_object
and fix up so it no longer requires an lcrecord.
These previous changes eliminate most of the remaining places where
the terms `lcrecord' and `lrecord' occurred outside of specialized
code.
(3) Fairly major change: Reduce the number of words in an lcrecord
from 3 to 2. The third word consisted of a uid that duplicated the
lrecord uid, and a single free bit, which was moved into the lrecord
structure. This reduces the size of the `uid' slot from 21 bits to
20 bits. Arguably this isn't enough -- we could easily have more than
1,000,000 or so objects created in a session. The answer is
(a) It doesn't really matter if we overflow the uid field because
it's only used for debugging, to identify an object uniquely
(or pretty much so).
(b) If we cared about it overflowing and wanted to reduce this,
we could make it so that cons, string, float and certain other
frob-block types that never print out the uid simply don't
store a uid in them and don't increment the lrecord_uid_counter.
(4) In conjunction with (3), create new macro NORMAL_LISP_OBJECT_UID()
and use it to abstract out the differences between NEWGC and old-GC
in accessing the `uid' value from a "normal Lisp Object pointer".
(5) In events.c, use zero_nonsized_lisp_object() in place of custom-
written equivalent. In font-mgr.c use external_object_printer()
in place of custom-written equivalents.
| author | Ben Wing <ben@xemacs.org> |
|---|---|
| date | Sat, 13 Mar 2010 05:38:08 -0600 |
| parents | 7be849cb8828 |
| children | 88bd4f3ef8e4 |
| rev | line source |
|---|---|
| 428 | 1 /* Generic Objects and Functions. |
| 2 Copyright (C) 1995 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:
4906
diff
changeset
|
4 Copyright (C) 1995, 1996, 2002, 2004, 2005, 2010 Ben Wing. |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
5 Copyright (C) 2010 Didier Verna |
| 428 | 6 |
| 7 This file is part of XEmacs. | |
| 8 | |
| 9 XEmacs is free software; you can redistribute it and/or modify it | |
| 10 under the terms of the GNU General Public License as published by the | |
| 11 Free Software Foundation; either version 2, or (at your option) any | |
| 12 later version. | |
| 13 | |
| 14 XEmacs is distributed in the hope that it will be useful, but WITHOUT | |
| 15 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
| 16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
| 17 for more details. | |
| 18 | |
| 19 You should have received a copy of the GNU General Public License | |
| 20 along with XEmacs; see the file COPYING. If not, write to | |
| 21 the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
| 22 Boston, MA 02111-1307, USA. */ | |
| 23 | |
| 24 /* Synched up with: Not in FSF. */ | |
| 25 | |
| 26 #include <config.h> | |
| 27 #include "lisp.h" | |
| 28 | |
| 771 | 29 #include "buffer.h" |
| 872 | 30 #include "device-impl.h" |
| 428 | 31 #include "elhash.h" |
| 32 #include "faces.h" | |
| 33 #include "frame.h" | |
| 800 | 34 #include "glyphs.h" |
| 872 | 35 #include "objects-impl.h" |
| 428 | 36 #include "specifier.h" |
| 37 #include "window.h" | |
| 38 | |
| 1204 | 39 #ifdef HAVE_TTY |
| 40 #include "console-tty.h" | |
| 41 #endif | |
| 934 | 42 |
| 428 | 43 /* Objects that are substituted when an instantiation fails. |
| 44 If we leave in the Qunbound value, we will probably get crashes. */ | |
| 45 Lisp_Object Vthe_null_color_instance, Vthe_null_font_instance; | |
| 46 | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
47 /* Author: Ben Wing; some earlier code from Chuck Thompson, Jamie |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
48 Zawinski. */ |
| 428 | 49 |
| 2268 | 50 DOESNT_RETURN |
| 428 | 51 finalose (void *ptr) |
| 52 { | |
| 793 | 53 Lisp_Object obj = wrap_pointer_1 (ptr); |
| 54 | |
| 563 | 55 invalid_operation |
| 428 | 56 ("Can't dump an emacs containing window system objects", obj); |
| 57 } | |
| 58 | |
| 59 | |
| 60 /**************************************************************************** | |
| 61 * Color-Instance Object * | |
| 62 ****************************************************************************/ | |
| 63 | |
| 64 Lisp_Object Qcolor_instancep; | |
| 65 | |
| 1204 | 66 static const struct memory_description color_instance_data_description_1 []= { |
| 67 #ifdef HAVE_TTY | |
| 3092 | 68 #ifdef NEW_GC |
| 69 { XD_LISP_OBJECT, tty_console }, | |
| 70 #else /* not NEW_GC */ | |
| 2551 | 71 { XD_BLOCK_PTR, tty_console, 1, { &tty_color_instance_data_description } }, |
| 3092 | 72 #endif /* not NEW_GC */ |
| 1204 | 73 #endif |
| 934 | 74 { XD_END } |
| 75 }; | |
| 76 | |
| 1204 | 77 static const struct sized_memory_description color_instance_data_description = { |
| 78 sizeof (void *), color_instance_data_description_1 | |
| 934 | 79 }; |
| 80 | |
| 1204 | 81 static const struct memory_description color_instance_description[] = { |
| 934 | 82 { XD_INT, offsetof (Lisp_Color_Instance, color_instance_type) }, |
| 83 { XD_LISP_OBJECT, offsetof (Lisp_Color_Instance, name)}, | |
| 84 { XD_LISP_OBJECT, offsetof (Lisp_Color_Instance, device)}, | |
| 1204 | 85 { XD_UNION, offsetof (Lisp_Color_Instance, data), |
| 2551 | 86 XD_INDIRECT (0, 0), { &color_instance_data_description } }, |
| 934 | 87 {XD_END} |
| 88 }; | |
| 89 | |
| 428 | 90 static Lisp_Object |
| 91 mark_color_instance (Lisp_Object obj) | |
| 92 { | |
| 440 | 93 Lisp_Color_Instance *c = XCOLOR_INSTANCE (obj); |
| 428 | 94 mark_object (c->name); |
| 95 if (!NILP (c->device)) /* Vthe_null_color_instance */ | |
| 96 MAYBE_DEVMETH (XDEVICE (c->device), mark_color_instance, (c)); | |
| 97 | |
| 98 return c->device; | |
| 99 } | |
| 100 | |
| 101 static void | |
| 102 print_color_instance (Lisp_Object obj, Lisp_Object printcharfun, | |
| 103 int escapeflag) | |
| 104 { | |
| 440 | 105 Lisp_Color_Instance *c = XCOLOR_INSTANCE (obj); |
| 428 | 106 if (print_readably) |
|
5142
f965e31a35f0
reduce lcrecord headers to 2 words, rename printing_unreadable_object
Ben Wing <ben@xemacs.org>
parents:
5128
diff
changeset
|
107 printing_unreadable_lisp_object (obj, 0); |
| 800 | 108 write_fmt_string_lisp (printcharfun, "#<color-instance %s", 1, c->name); |
| 109 write_fmt_string_lisp (printcharfun, " on %s", 1, c->device); | |
| 428 | 110 if (!NILP (c->device)) /* Vthe_null_color_instance */ |
| 111 MAYBE_DEVMETH (XDEVICE (c->device), print_color_instance, | |
| 112 (c, printcharfun, escapeflag)); | |
|
5142
f965e31a35f0
reduce lcrecord headers to 2 words, rename printing_unreadable_object
Ben Wing <ben@xemacs.org>
parents:
5128
diff
changeset
|
113 write_fmt_string (printcharfun, " 0x%x>", NORMAL_LISP_OBJECT_UID (c)); |
| 428 | 114 } |
| 115 | |
| 116 static void | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
117 finalize_color_instance (Lisp_Object obj) |
| 428 | 118 { |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
119 Lisp_Color_Instance *c = XCOLOR_INSTANCE (obj); |
| 428 | 120 |
| 121 if (!NILP (c->device)) | |
|
5124
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
122 MAYBE_DEVMETH (XDEVICE (c->device), finalize_color_instance, (c)); |
| 428 | 123 } |
| 124 | |
| 125 static int | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
126 color_instance_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:
4846
diff
changeset
|
127 int UNUSED (foldcase)) |
| 428 | 128 { |
| 440 | 129 Lisp_Color_Instance *c1 = XCOLOR_INSTANCE (obj1); |
| 130 Lisp_Color_Instance *c2 = XCOLOR_INSTANCE (obj2); | |
| 428 | 131 |
| 132 return (c1 == c2) || | |
| 133 (EQ (c1->device, c2->device) && | |
| 134 DEVICEP (c1->device) && | |
| 135 HAS_DEVMETH_P (XDEVICE (c1->device), color_instance_equal) && | |
| 136 DEVMETH (XDEVICE (c1->device), color_instance_equal, (c1, c2, depth))); | |
| 137 } | |
| 138 | |
| 2515 | 139 static Hashcode |
| 428 | 140 color_instance_hash (Lisp_Object obj, int depth) |
| 141 { | |
| 440 | 142 Lisp_Color_Instance *c = XCOLOR_INSTANCE (obj); |
| 428 | 143 struct device *d = DEVICEP (c->device) ? XDEVICE (c->device) : 0; |
| 144 | |
| 2515 | 145 return HASH2 ((Hashcode) d, |
| 428 | 146 !d ? LISP_HASH (obj) |
| 147 : DEVMETH_OR_GIVEN (d, color_instance_hash, (c, depth), | |
| 148 LISP_HASH (obj))); | |
| 149 } | |
| 150 | |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
151 DEFINE_NODUMP_LISP_OBJECT ("color-instance", color_instance, |
|
5124
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
152 mark_color_instance, print_color_instance, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
153 finalize_color_instance, color_instance_equal, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
154 color_instance_hash, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
155 color_instance_description, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
156 Lisp_Color_Instance); |
| 428 | 157 |
| 158 DEFUN ("make-color-instance", Fmake_color_instance, 1, 3, 0, /* | |
| 159 Return a new `color-instance' object named NAME (a string). | |
| 160 | |
| 161 Optional argument DEVICE specifies the device this object applies to | |
| 162 and defaults to the selected device. | |
| 163 | |
| 164 An error is signaled if the color is unknown or cannot be allocated; | |
| 444 | 165 however, if optional argument NOERROR is non-nil, nil is simply |
| 166 returned in this case. (And if NOERROR is other than t, a warning may | |
| 428 | 167 be issued.) |
| 168 | |
| 169 The returned object is a normal, first-class lisp object. The way you | |
| 170 `deallocate' the color is the way you deallocate any other lisp object: | |
| 171 you drop all pointers to it and allow it to be garbage collected. When | |
| 172 these objects are GCed, the underlying window-system data (e.g. X object) | |
| 173 is deallocated as well. | |
| 174 */ | |
| 444 | 175 (name, device, noerror)) |
| 428 | 176 { |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
177 Lisp_Object obj; |
| 440 | 178 Lisp_Color_Instance *c; |
| 428 | 179 int retval; |
| 180 | |
| 181 CHECK_STRING (name); | |
| 793 | 182 device = wrap_device (decode_device (device)); |
| 428 | 183 |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
184 obj = ALLOC_NORMAL_LISP_OBJECT (color_instance); |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
185 c = XCOLOR_INSTANCE (obj); |
| 428 | 186 c->name = name; |
| 187 c->device = device; | |
| 188 c->data = 0; | |
| 1204 | 189 c->color_instance_type = get_console_variant (XDEVICE_TYPE (c->device)); |
| 428 | 190 |
| 191 retval = MAYBE_INT_DEVMETH (XDEVICE (device), initialize_color_instance, | |
| 192 (c, name, device, | |
| 444 | 193 decode_error_behavior_flag (noerror))); |
| 428 | 194 if (!retval) |
| 195 return Qnil; | |
| 196 | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
197 return obj; |
| 428 | 198 } |
| 199 | |
| 200 DEFUN ("color-instance-p", Fcolor_instance_p, 1, 1, 0, /* | |
| 201 Return non-nil if OBJECT is a color instance. | |
| 202 */ | |
| 203 (object)) | |
| 204 { | |
| 205 return COLOR_INSTANCEP (object) ? Qt : Qnil; | |
| 206 } | |
| 207 | |
| 208 DEFUN ("color-instance-name", Fcolor_instance_name, 1, 1, 0, /* | |
| 209 Return the name used to allocate COLOR-INSTANCE. | |
| 210 */ | |
| 211 (color_instance)) | |
| 212 { | |
| 213 CHECK_COLOR_INSTANCE (color_instance); | |
| 214 return XCOLOR_INSTANCE (color_instance)->name; | |
| 215 } | |
| 216 | |
| 217 DEFUN ("color-instance-rgb-components", Fcolor_instance_rgb_components, 1, 1, 0, /* | |
| 218 Return a three element list containing the red, green, and blue | |
| 219 color components of COLOR-INSTANCE, or nil if unknown. | |
| 220 Component values range from 0 to 65535. | |
| 221 */ | |
| 222 (color_instance)) | |
| 223 { | |
| 440 | 224 Lisp_Color_Instance *c; |
| 428 | 225 |
| 226 CHECK_COLOR_INSTANCE (color_instance); | |
| 227 c = XCOLOR_INSTANCE (color_instance); | |
| 228 | |
| 229 if (NILP (c->device)) | |
| 230 return Qnil; | |
| 231 | |
| 232 return MAYBE_LISP_DEVMETH (XDEVICE (c->device), | |
| 233 color_instance_rgb_components, | |
| 234 (c)); | |
| 235 } | |
| 236 | |
| 237 DEFUN ("valid-color-name-p", Fvalid_color_name_p, 1, 2, 0, /* | |
| 238 Return true if COLOR names a valid color for the current device. | |
| 239 | |
| 240 Valid color names for X are listed in the file /usr/lib/X11/rgb.txt, or | |
| 241 whatever the equivalent is on your system. | |
| 242 | |
| 243 Valid color names for TTY are those which have an ISO 6429 (ANSI) sequence. | |
| 244 In addition to being a color this may be one of a number of attributes | |
| 245 such as `blink'. | |
| 246 */ | |
| 247 (color, device)) | |
| 248 { | |
| 249 struct device *d = decode_device (device); | |
| 250 | |
| 251 CHECK_STRING (color); | |
| 252 return MAYBE_INT_DEVMETH (d, valid_color_name_p, (d, color)) ? Qt : Qnil; | |
| 253 } | |
| 254 | |
| 2527 | 255 DEFUN ("color-list", Fcolor_list, 0, 1, 0, /* |
| 256 Return a list of color names. | |
| 257 DEVICE specifies which device to return names for, and defaults to the | |
| 258 currently selected device. | |
| 259 */ | |
| 260 (device)) | |
| 261 { | |
| 262 device = wrap_device (decode_device (device)); | |
| 263 | |
| 264 return MAYBE_LISP_DEVMETH (XDEVICE (device), color_list, ()); | |
| 265 } | |
| 266 | |
| 428 | 267 |
| 268 /*************************************************************************** | |
| 269 * Font-Instance Object * | |
| 270 ***************************************************************************/ | |
| 271 | |
| 272 Lisp_Object Qfont_instancep; | |
| 273 | |
| 274 static Lisp_Object font_instance_truename_internal (Lisp_Object xfont, | |
| 578 | 275 Error_Behavior errb); |
| 934 | 276 |
| 1204 | 277 static const struct memory_description font_instance_data_description_1 []= { |
| 278 #ifdef HAVE_TTY | |
| 3092 | 279 #ifdef NEW_GC |
| 280 { XD_LISP_OBJECT, tty_console }, | |
| 281 #else /* not NEW_GC */ | |
| 282 { XD_BLOCK_PTR, tty_console, 1, { &tty_font_instance_data_description } }, | |
| 283 #endif /* not NEW_GC */ | |
| 1204 | 284 #endif |
| 934 | 285 { XD_END } |
| 286 }; | |
| 287 | |
| 1204 | 288 static const struct sized_memory_description font_instance_data_description = { |
| 289 sizeof (void *), font_instance_data_description_1 | |
| 934 | 290 }; |
| 291 | |
| 1204 | 292 static const struct memory_description font_instance_description[] = { |
| 934 | 293 { XD_INT, offsetof (Lisp_Font_Instance, font_instance_type) }, |
| 294 { XD_LISP_OBJECT, offsetof (Lisp_Font_Instance, name)}, | |
| 295 { XD_LISP_OBJECT, offsetof (Lisp_Font_Instance, truename)}, | |
| 296 { XD_LISP_OBJECT, offsetof (Lisp_Font_Instance, device)}, | |
| 3094 | 297 { XD_LISP_OBJECT, offsetof (Lisp_Font_Instance, charset)}, |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
298 { XD_UNION, offsetof (Lisp_Font_Instance, data), |
| 2551 | 299 XD_INDIRECT (0, 0), { &font_instance_data_description } }, |
| 1204 | 300 { XD_END } |
| 934 | 301 }; |
| 302 | |
| 428 | 303 |
| 304 static Lisp_Object | |
| 305 mark_font_instance (Lisp_Object obj) | |
| 306 { | |
| 440 | 307 Lisp_Font_Instance *f = XFONT_INSTANCE (obj); |
| 428 | 308 |
| 309 mark_object (f->name); | |
| 872 | 310 mark_object (f->truename); |
| 428 | 311 if (!NILP (f->device)) /* Vthe_null_font_instance */ |
| 312 MAYBE_DEVMETH (XDEVICE (f->device), mark_font_instance, (f)); | |
| 313 | |
| 314 return f->device; | |
| 315 } | |
| 316 | |
| 317 static void | |
| 318 print_font_instance (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) | |
| 319 { | |
| 440 | 320 Lisp_Font_Instance *f = XFONT_INSTANCE (obj); |
| 428 | 321 if (print_readably) |
|
5142
f965e31a35f0
reduce lcrecord headers to 2 words, rename printing_unreadable_object
Ben Wing <ben@xemacs.org>
parents:
5128
diff
changeset
|
322 printing_unreadable_lisp_object (obj, 0); |
| 800 | 323 write_fmt_string_lisp (printcharfun, "#<font-instance %S", 1, f->name); |
| 324 write_fmt_string_lisp (printcharfun, " on %s", 1, f->device); | |
| 428 | 325 if (!NILP (f->device)) |
| 3659 | 326 { |
| 327 MAYBE_DEVMETH (XDEVICE (f->device), print_font_instance, | |
| 328 (f, printcharfun, escapeflag)); | |
| 329 | |
| 330 } | |
|
5142
f965e31a35f0
reduce lcrecord headers to 2 words, rename printing_unreadable_object
Ben Wing <ben@xemacs.org>
parents:
5128
diff
changeset
|
331 write_fmt_string (printcharfun, " 0x%x>", NORMAL_LISP_OBJECT_UID (f)); |
| 428 | 332 } |
| 333 | |
| 334 static void | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
335 finalize_font_instance (Lisp_Object obj) |
| 428 | 336 { |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
337 Lisp_Font_Instance *f = XFONT_INSTANCE (obj); |
| 428 | 338 |
| 339 if (!NILP (f->device)) | |
| 340 { | |
| 341 MAYBE_DEVMETH (XDEVICE (f->device), finalize_font_instance, (f)); | |
| 342 } | |
| 343 } | |
| 344 | |
| 345 /* Fonts are equal if they resolve to the same name. | |
| 346 Since we call `font-truename' to do this, and since font-truename is lazy, | |
| 347 this means the `equal' could cause XListFonts to be run the first time. | |
| 348 */ | |
| 349 static int | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
350 font_instance_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:
4846
diff
changeset
|
351 int UNUSED (foldcase)) |
| 428 | 352 { |
| 353 /* #### should this be moved into a device method? */ | |
| 793 | 354 return internal_equal (font_instance_truename_internal |
| 355 (obj1, ERROR_ME_DEBUG_WARN), | |
| 356 font_instance_truename_internal | |
| 357 (obj2, ERROR_ME_DEBUG_WARN), | |
| 428 | 358 depth + 1); |
| 359 } | |
| 360 | |
| 2515 | 361 static Hashcode |
| 428 | 362 font_instance_hash (Lisp_Object obj, int depth) |
| 363 { | |
| 793 | 364 return internal_hash (font_instance_truename_internal |
| 365 (obj, ERROR_ME_DEBUG_WARN), | |
| 428 | 366 depth + 1); |
| 367 } | |
| 368 | |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
369 DEFINE_NODUMP_LISP_OBJECT ("font-instance", font_instance, |
|
5124
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
370 mark_font_instance, print_font_instance, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
371 finalize_font_instance, font_instance_equal, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
372 font_instance_hash, font_instance_description, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
373 Lisp_Font_Instance); |
| 934 | 374 |
| 428 | 375 |
| 3094 | 376 /* #### Why is this exposed to Lisp? Used in: |
| 377 x-frob-font-size, gtk-font-menu-load-font, x-font-menu-load-font-xft, | |
| 378 x-font-menu-load-font-core, mswindows-font-menu-load-font, | |
| 379 mswindows-frob-font-style-and-sizify, mswindows-frob-font-size. */ | |
| 380 DEFUN ("make-font-instance", Fmake_font_instance, 1, 4, 0, /* | |
| 428 | 381 Return a new `font-instance' object named NAME. |
| 382 DEVICE specifies the device this object applies to and defaults to the | |
| 383 selected device. An error is signalled if the font is unknown or cannot | |
| 384 be allocated; however, if NOERROR is non-nil, nil is simply returned in | |
| 3094 | 385 this case. CHARSET is used internally. #### make helper function? |
| 428 | 386 |
| 387 The returned object is a normal, first-class lisp object. The way you | |
| 388 `deallocate' the font is the way you deallocate any other lisp object: | |
| 389 you drop all pointers to it and allow it to be garbage collected. When | |
| 3094 | 390 these objects are GCed, the underlying GUI data is deallocated as well. |
| 428 | 391 */ |
| 3094 | 392 (name, device, noerror, charset)) |
| 428 | 393 { |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
394 Lisp_Object obj; |
| 440 | 395 Lisp_Font_Instance *f; |
| 428 | 396 int retval = 0; |
| 578 | 397 Error_Behavior errb = decode_error_behavior_flag (noerror); |
| 428 | 398 |
| 399 if (ERRB_EQ (errb, ERROR_ME)) | |
| 400 CHECK_STRING (name); | |
| 401 else if (!STRINGP (name)) | |
| 402 return Qnil; | |
| 403 | |
| 793 | 404 device = wrap_device (decode_device (device)); |
| 428 | 405 |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
406 obj = ALLOC_NORMAL_LISP_OBJECT (font_instance); |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
407 f = XFONT_INSTANCE (obj); |
| 428 | 408 f->name = name; |
| 872 | 409 f->truename = Qnil; |
| 428 | 410 f->device = device; |
| 411 | |
| 412 f->data = 0; | |
| 1204 | 413 f->font_instance_type = get_console_variant (XDEVICE_TYPE (f->device)); |
| 428 | 414 |
| 415 /* Stick some default values here ... */ | |
| 416 f->ascent = f->height = 1; | |
| 417 f->descent = 0; | |
| 418 f->width = 1; | |
| 3094 | 419 f->charset = charset; |
| 428 | 420 f->proportional_p = 0; |
| 421 | |
| 422 retval = MAYBE_INT_DEVMETH (XDEVICE (device), initialize_font_instance, | |
| 423 (f, name, device, errb)); | |
| 424 | |
| 425 if (!retval) | |
| 426 return Qnil; | |
| 427 | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
428 return obj; |
| 428 | 429 } |
| 430 | |
| 431 DEFUN ("font-instance-p", Ffont_instance_p, 1, 1, 0, /* | |
| 432 Return non-nil if OBJECT is a font instance. | |
| 433 */ | |
| 434 (object)) | |
| 435 { | |
| 436 return FONT_INSTANCEP (object) ? Qt : Qnil; | |
| 437 } | |
| 438 | |
| 439 DEFUN ("font-instance-name", Ffont_instance_name, 1, 1, 0, /* | |
| 440 Return the name used to allocate FONT-INSTANCE. | |
| 441 */ | |
| 442 (font_instance)) | |
| 443 { | |
| 444 CHECK_FONT_INSTANCE (font_instance); | |
| 445 return XFONT_INSTANCE (font_instance)->name; | |
| 446 } | |
| 447 | |
| 448 DEFUN ("font-instance-ascent", Ffont_instance_ascent, 1, 1, 0, /* | |
| 449 Return the ascent in pixels of FONT-INSTANCE. | |
| 450 The returned value is the maximum ascent for all characters in the font, | |
| 451 where a character's ascent is the number of pixels above (and including) | |
| 452 the baseline. | |
| 453 */ | |
| 454 (font_instance)) | |
| 455 { | |
| 456 CHECK_FONT_INSTANCE (font_instance); | |
| 457 return make_int (XFONT_INSTANCE (font_instance)->ascent); | |
| 458 } | |
| 459 | |
| 460 DEFUN ("font-instance-descent", Ffont_instance_descent, 1, 1, 0, /* | |
| 461 Return the descent in pixels of FONT-INSTANCE. | |
| 462 The returned value is the maximum descent for all characters in the font, | |
| 463 where a character's descent is the number of pixels below the baseline. | |
| 464 \(Many characters to do not have any descent. Typical characters with a | |
| 465 descent are lowercase p and lowercase g.) | |
| 466 */ | |
| 467 (font_instance)) | |
| 468 { | |
| 469 CHECK_FONT_INSTANCE (font_instance); | |
| 470 return make_int (XFONT_INSTANCE (font_instance)->descent); | |
| 471 } | |
| 472 | |
| 473 DEFUN ("font-instance-width", Ffont_instance_width, 1, 1, 0, /* | |
| 474 Return the width in pixels of FONT-INSTANCE. | |
| 475 The returned value is the average width for all characters in the font. | |
| 476 */ | |
| 477 (font_instance)) | |
| 478 { | |
| 479 CHECK_FONT_INSTANCE (font_instance); | |
| 480 return make_int (XFONT_INSTANCE (font_instance)->width); | |
| 481 } | |
| 482 | |
| 483 DEFUN ("font-instance-proportional-p", Ffont_instance_proportional_p, 1, 1, 0, /* | |
| 484 Return whether FONT-INSTANCE is proportional. | |
| 485 This means that different characters in the font have different widths. | |
| 486 */ | |
| 487 (font_instance)) | |
| 488 { | |
| 489 CHECK_FONT_INSTANCE (font_instance); | |
| 490 return XFONT_INSTANCE (font_instance)->proportional_p ? Qt : Qnil; | |
| 491 } | |
| 492 | |
| 493 static Lisp_Object | |
| 494 font_instance_truename_internal (Lisp_Object font_instance, | |
| 578 | 495 Error_Behavior errb) |
| 428 | 496 { |
| 440 | 497 Lisp_Font_Instance *f = XFONT_INSTANCE (font_instance); |
| 498 | |
| 428 | 499 if (NILP (f->device)) |
| 500 { | |
|
4757
a23ac8f90a49
Improve warning and error messages from Xft.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4426
diff
changeset
|
501 maybe_signal_error (Qgui_error, |
|
a23ac8f90a49
Improve warning and error messages from Xft.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4426
diff
changeset
|
502 "can't determine truename: " |
|
a23ac8f90a49
Improve warning and error messages from Xft.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4426
diff
changeset
|
503 "no device for font instance", |
|
a23ac8f90a49
Improve warning and error messages from Xft.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4426
diff
changeset
|
504 font_instance, Qfont, errb); |
| 428 | 505 return Qnil; |
| 506 } | |
| 440 | 507 |
| 428 | 508 return DEVMETH_OR_GIVEN (XDEVICE (f->device), |
| 509 font_instance_truename, (f, errb), f->name); | |
| 510 } | |
| 511 | |
| 512 DEFUN ("font-instance-truename", Ffont_instance_truename, 1, 1, 0, /* | |
| 513 Return the canonical name of FONT-INSTANCE. | |
| 514 Font names are patterns which may match any number of fonts, of which | |
| 515 the first found is used. This returns an unambiguous name for that font | |
| 516 \(but not necessarily its only unambiguous name). | |
| 517 */ | |
| 518 (font_instance)) | |
| 519 { | |
| 520 CHECK_FONT_INSTANCE (font_instance); | |
| 521 return font_instance_truename_internal (font_instance, ERROR_ME); | |
| 522 } | |
| 523 | |
| 3094 | 524 DEFUN ("font-instance-charset", Ffont_instance_charset, 1, 1, 0, /* |
| 525 Return the Mule charset that FONT-INSTANCE was allocated to handle. | |
| 526 */ | |
| 527 (font_instance)) | |
| 528 { | |
| 529 CHECK_FONT_INSTANCE (font_instance); | |
| 530 return XFONT_INSTANCE (font_instance)->charset; | |
| 531 } | |
| 532 | |
| 428 | 533 DEFUN ("font-instance-properties", Ffont_instance_properties, 1, 1, 0, /* |
| 534 Return the properties (an alist or nil) of FONT-INSTANCE. | |
| 535 */ | |
| 536 (font_instance)) | |
| 537 { | |
| 440 | 538 Lisp_Font_Instance *f; |
| 428 | 539 |
| 540 CHECK_FONT_INSTANCE (font_instance); | |
| 541 f = XFONT_INSTANCE (font_instance); | |
| 542 | |
| 543 if (NILP (f->device)) | |
| 544 return Qnil; | |
| 545 | |
| 546 return MAYBE_LISP_DEVMETH (XDEVICE (f->device), | |
| 547 font_instance_properties, (f)); | |
| 548 } | |
| 549 | |
| 2527 | 550 DEFUN ("font-list", Ffont_list, 1, 3, 0, /* |
| 428 | 551 Return a list of font names matching the given pattern. |
| 552 DEVICE specifies which device to search for names, and defaults to the | |
| 553 currently selected device. | |
| 554 */ | |
| 1701 | 555 (pattern, device, maxnumber)) |
| 428 | 556 { |
| 557 CHECK_STRING (pattern); | |
| 793 | 558 device = wrap_device (decode_device (device)); |
| 428 | 559 |
| 2527 | 560 return MAYBE_LISP_DEVMETH (XDEVICE (device), font_list, (pattern, device, |
| 1701 | 561 maxnumber)); |
| 428 | 562 } |
| 563 | |
| 564 | |
| 565 /**************************************************************************** | |
| 566 Color Object | |
| 567 ***************************************************************************/ | |
| 1204 | 568 |
| 569 static const struct memory_description color_specifier_description[] = { | |
| 570 { XD_LISP_OBJECT, offsetof (struct color_specifier, face) }, | |
| 571 { XD_LISP_OBJECT, offsetof (struct color_specifier, face_property) }, | |
| 572 { XD_END } | |
| 573 }; | |
| 574 | |
| 575 DEFINE_SPECIFIER_TYPE_WITH_DATA (color); | |
| 428 | 576 /* Qcolor defined in general.c */ |
| 577 | |
| 578 static void | |
| 579 color_create (Lisp_Object obj) | |
| 580 { | |
| 440 | 581 Lisp_Specifier *color = XCOLOR_SPECIFIER (obj); |
| 428 | 582 |
| 583 COLOR_SPECIFIER_FACE (color) = Qnil; | |
| 584 COLOR_SPECIFIER_FACE_PROPERTY (color) = Qnil; | |
| 585 } | |
| 586 | |
| 587 static void | |
| 588 color_mark (Lisp_Object obj) | |
| 589 { | |
| 440 | 590 Lisp_Specifier *color = XCOLOR_SPECIFIER (obj); |
| 428 | 591 |
| 592 mark_object (COLOR_SPECIFIER_FACE (color)); | |
| 593 mark_object (COLOR_SPECIFIER_FACE_PROPERTY (color)); | |
| 594 } | |
| 595 | |
| 596 /* No equal or hash methods; ignore the face the color is based off | |
| 597 of for `equal' */ | |
| 598 | |
| 599 static Lisp_Object | |
| 2286 | 600 color_instantiate (Lisp_Object specifier, Lisp_Object UNUSED (matchspec), |
| 428 | 601 Lisp_Object domain, Lisp_Object instantiator, |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
602 Lisp_Object depth, int no_fallback) |
| 428 | 603 { |
| 604 /* When called, we're inside of call_with_suspended_errors(), | |
| 605 so we can freely error. */ | |
| 442 | 606 Lisp_Object device = DOMAIN_DEVICE (domain); |
| 428 | 607 struct device *d = XDEVICE (device); |
| 608 | |
| 609 if (COLOR_INSTANCEP (instantiator)) | |
| 610 { | |
| 611 /* If we are on the same device then we're done. Otherwise change | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
612 the instantiator to the name used to generate the pixel and let the |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
613 STRINGP case deal with it. */ |
| 428 | 614 if (NILP (device) /* Vthe_null_color_instance */ |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
615 || EQ (device, XCOLOR_INSTANCE (instantiator)->device)) |
| 428 | 616 return instantiator; |
| 617 else | |
| 618 instantiator = Fcolor_instance_name (instantiator); | |
| 619 } | |
| 620 | |
| 621 if (STRINGP (instantiator)) | |
| 622 { | |
| 623 /* First, look to see if we can retrieve a cached value. */ | |
| 624 Lisp_Object instance = | |
| 625 Fgethash (instantiator, d->color_instance_cache, Qunbound); | |
| 626 /* Otherwise, make a new one. */ | |
| 627 if (UNBOUNDP (instance)) | |
| 628 { | |
| 629 /* make sure we cache the failures, too. */ | |
| 630 instance = Fmake_color_instance (instantiator, device, Qt); | |
| 631 Fputhash (instantiator, instance, d->color_instance_cache); | |
| 632 } | |
| 633 | |
| 634 return NILP (instance) ? Qunbound : instance; | |
| 635 } | |
| 636 else if (VECTORP (instantiator)) | |
| 637 { | |
| 638 switch (XVECTOR_LENGTH (instantiator)) | |
| 639 { | |
| 640 case 0: | |
| 641 if (DEVICE_TTY_P (d)) | |
| 642 return Vthe_null_color_instance; | |
| 643 else | |
| 563 | 644 gui_error ("Color instantiator [] only valid on TTY's", |
| 428 | 645 device); |
| 646 | |
| 647 case 1: | |
| 648 if (NILP (COLOR_SPECIFIER_FACE (XCOLOR_SPECIFIER (specifier)))) | |
| 563 | 649 gui_error ("Color specifier not attached to a face", |
| 428 | 650 instantiator); |
| 651 return (FACE_PROPERTY_INSTANCE_1 | |
| 652 (Fget_face (XVECTOR_DATA (instantiator)[0]), | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
653 COLOR_SPECIFIER_FACE_PROPERTY |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
654 (XCOLOR_SPECIFIER (specifier)), |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
655 domain, ERROR_ME, no_fallback, depth)); |
| 428 | 656 |
| 657 case 2: | |
| 658 return (FACE_PROPERTY_INSTANCE_1 | |
| 659 (Fget_face (XVECTOR_DATA (instantiator)[0]), | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
660 XVECTOR_DATA (instantiator)[1], domain, ERROR_ME, |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
661 no_fallback, depth)); |
| 428 | 662 |
| 663 default: | |
| 2500 | 664 ABORT (); |
| 428 | 665 } |
| 666 } | |
| 667 else if (NILP (instantiator)) | |
| 668 { | |
| 669 if (DEVICE_TTY_P (d)) | |
| 670 return Vthe_null_color_instance; | |
| 671 else | |
| 563 | 672 gui_error ("Color instantiator [] only valid on TTY's", |
| 428 | 673 device); |
| 674 } | |
| 675 else | |
| 2500 | 676 ABORT (); /* The spec validation routines are screwed up. */ |
| 428 | 677 |
| 678 return Qunbound; | |
| 679 } | |
| 680 | |
| 681 static void | |
| 682 color_validate (Lisp_Object instantiator) | |
| 683 { | |
| 684 if (COLOR_INSTANCEP (instantiator) || STRINGP (instantiator)) | |
| 685 return; | |
| 686 if (VECTORP (instantiator)) | |
| 687 { | |
| 688 if (XVECTOR_LENGTH (instantiator) > 2) | |
| 563 | 689 sferror ("Inheritance vector must be of size 0 - 2", |
| 428 | 690 instantiator); |
| 691 else if (XVECTOR_LENGTH (instantiator) > 0) | |
| 692 { | |
| 693 Lisp_Object face = XVECTOR_DATA (instantiator)[0]; | |
| 694 | |
| 695 Fget_face (face); | |
| 696 if (XVECTOR_LENGTH (instantiator) == 2) | |
| 697 { | |
| 698 Lisp_Object field = XVECTOR_DATA (instantiator)[1]; | |
| 699 if (!EQ (field, Qforeground) && !EQ (field, Qbackground)) | |
| 563 | 700 invalid_constant |
| 428 | 701 ("Inheritance field must be `foreground' or `background'", |
| 702 field); | |
| 703 } | |
| 704 } | |
| 705 } | |
| 706 else | |
| 563 | 707 invalid_argument ("Invalid color instantiator", instantiator); |
| 428 | 708 } |
| 709 | |
| 710 static void | |
| 711 color_after_change (Lisp_Object specifier, Lisp_Object locale) | |
| 712 { | |
| 713 Lisp_Object face = COLOR_SPECIFIER_FACE (XCOLOR_SPECIFIER (specifier)); | |
| 714 Lisp_Object property = | |
| 715 COLOR_SPECIFIER_FACE_PROPERTY (XCOLOR_SPECIFIER (specifier)); | |
| 716 if (!NILP (face)) | |
| 448 | 717 { |
| 718 face_property_was_changed (face, property, locale); | |
| 719 if (BUFFERP (locale)) | |
| 720 XBUFFER (locale)->buffer_local_face_property = 1; | |
| 721 } | |
| 428 | 722 } |
| 723 | |
| 724 void | |
| 725 set_color_attached_to (Lisp_Object obj, Lisp_Object face, Lisp_Object property) | |
| 726 { | |
| 440 | 727 Lisp_Specifier *color = XCOLOR_SPECIFIER (obj); |
| 428 | 728 |
| 729 COLOR_SPECIFIER_FACE (color) = face; | |
| 730 COLOR_SPECIFIER_FACE_PROPERTY (color) = property; | |
| 731 } | |
| 732 | |
| 733 DEFUN ("color-specifier-p", Fcolor_specifier_p, 1, 1, 0, /* | |
| 734 Return t if OBJECT is a color specifier. | |
| 735 | |
| 442 | 736 See `make-color-specifier' for a description of possible color instantiators. |
| 428 | 737 */ |
| 738 (object)) | |
| 739 { | |
| 740 return COLOR_SPECIFIERP (object) ? Qt : Qnil; | |
| 741 } | |
| 742 | |
| 743 | |
| 744 /**************************************************************************** | |
| 745 Font Object | |
| 746 ***************************************************************************/ | |
| 1204 | 747 |
| 748 static const struct memory_description font_specifier_description[] = { | |
| 749 { XD_LISP_OBJECT, offsetof (struct font_specifier, face) }, | |
| 750 { XD_LISP_OBJECT, offsetof (struct font_specifier, face_property) }, | |
| 751 { XD_END } | |
| 752 }; | |
| 753 | |
| 754 DEFINE_SPECIFIER_TYPE_WITH_DATA (font); | |
| 428 | 755 /* Qfont defined in general.c */ |
| 756 | |
| 757 static void | |
| 758 font_create (Lisp_Object obj) | |
| 759 { | |
| 440 | 760 Lisp_Specifier *font = XFONT_SPECIFIER (obj); |
| 428 | 761 |
| 762 FONT_SPECIFIER_FACE (font) = Qnil; | |
| 763 FONT_SPECIFIER_FACE_PROPERTY (font) = Qnil; | |
| 764 } | |
| 765 | |
| 766 static void | |
| 767 font_mark (Lisp_Object obj) | |
| 768 { | |
| 440 | 769 Lisp_Specifier *font = XFONT_SPECIFIER (obj); |
| 428 | 770 |
| 771 mark_object (FONT_SPECIFIER_FACE (font)); | |
| 772 mark_object (FONT_SPECIFIER_FACE_PROPERTY (font)); | |
| 773 } | |
| 774 | |
| 775 /* No equal or hash methods; ignore the face the font is based off | |
| 776 of for `equal' */ | |
| 777 | |
| 778 #ifdef MULE | |
| 779 | |
| 872 | 780 /* Given a truename font spec (i.e. the font spec should have its registry |
| 781 field filled in), does it support displaying characters from CHARSET? */ | |
| 782 | |
| 783 static int | |
| 428 | 784 font_spec_matches_charset (struct device *d, Lisp_Object charset, |
| 867 | 785 const Ibyte *nonreloc, Lisp_Object reloc, |
| 872 | 786 Bytecount offset, Bytecount length, |
| 3659 | 787 enum font_specifier_matchspec_stages stage) |
| 428 | 788 { |
| 789 return DEVMETH_OR_GIVEN (d, font_spec_matches_charset, | |
| 872 | 790 (d, charset, nonreloc, reloc, offset, length, |
| 791 stage), | |
| 428 | 792 1); |
| 793 } | |
| 794 | |
| 795 static void | |
| 796 font_validate_matchspec (Lisp_Object matchspec) | |
| 797 { | |
| 872 | 798 CHECK_CONS (matchspec); |
| 799 Fget_charset (XCAR (matchspec)); | |
| 3659 | 800 |
| 801 do | |
| 802 { | |
| 803 if (EQ(XCDR(matchspec), Qinitial)) | |
| 804 { | |
| 805 break; | |
| 806 } | |
| 807 if (EQ(XCDR(matchspec), Qfinal)) | |
| 808 { | |
| 809 break; | |
| 810 } | |
| 811 | |
| 812 invalid_argument("Invalid font matchspec stage", | |
| 813 XCDR(matchspec)); | |
| 814 } while (0); | |
| 428 | 815 } |
| 816 | |
| 872 | 817 void |
| 818 initialize_charset_font_caches (struct device *d) | |
| 819 { | |
| 820 /* Note that the following tables are bi-level. */ | |
| 821 d->charset_font_cache_stage_1 = | |
| 822 make_lisp_hash_table (20, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); | |
| 823 d->charset_font_cache_stage_2 = | |
| 824 make_lisp_hash_table (20, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); | |
| 825 } | |
| 826 | |
| 827 void | |
| 828 invalidate_charset_font_caches (Lisp_Object charset) | |
| 829 { | |
| 830 /* Invalidate font cache entries for charset on all devices. */ | |
| 831 Lisp_Object devcons, concons, hash_table; | |
| 832 DEVICE_LOOP_NO_BREAK (devcons, concons) | |
| 833 { | |
| 834 struct device *d = XDEVICE (XCAR (devcons)); | |
| 835 hash_table = Fgethash (charset, d->charset_font_cache_stage_1, | |
| 836 Qunbound); | |
| 837 if (!UNBOUNDP (hash_table)) | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
838 Fclrhash (hash_table); |
| 872 | 839 hash_table = Fgethash (charset, d->charset_font_cache_stage_2, |
| 840 Qunbound); | |
| 841 if (!UNBOUNDP (hash_table)) | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
842 Fclrhash (hash_table); |
| 872 | 843 } |
| 844 } | |
| 428 | 845 |
| 874 | 846 #endif /* MULE */ |
| 847 | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
848 /* It's a little non-obvious what's going on here. Specifically: |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
849 |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
850 MATCHSPEC is a somewhat bogus way in the specifier mechanism of passing |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
851 in additional information needed to instantiate some object. For fonts, |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
852 it's a cons of (CHARSET . SECOND-STAGE-P). SECOND-STAGE-P, if set, |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
853 means "try harder to find an appropriate font" and is a very bogus way |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
854 of dealing with the fact that it may not be possible to may a charset |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
855 directly onto a font; it's used esp. under Windows. @@#### We need to |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
856 change this so that MATCHSPEC is just a character. |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
857 |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
858 When redisplay is building up its structure, and needs font info, it |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
859 calls functions in faces.c such as ensure_face_cachel_complete() (map |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
860 fonts needed for a string of text) or |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
861 ensure_face_cachel_contains_charset() (map fonts needed for a charset |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
862 derived from a single character). The former function calls the latter; |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
863 the latter calls face_property_matching_instance(); this constructs the |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
864 MATCHSPEC and calls specifier_instance_no_quit() twice (first stage and |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
865 second stage, updating MATCHSPEC appropriately). That function, in |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
866 turn, looks up the appropriate specifier method to do the instantiation, |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
867 which, lo and behold, is this function here (because we set it in |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
868 initialization using `SPECIFIER_HAS_METHOD (font, instantiate);'). We |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
869 in turn call the device method `find_charset_font', which maps to |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
870 mswindows_find_charset_font(), x_find_charset_font(), or similar, in |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
871 objects-msw.c or the like. |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
872 |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
873 --ben */ |
| 874 | 874 |
| 428 | 875 static Lisp_Object |
| 2333 | 876 font_instantiate (Lisp_Object UNUSED (specifier), |
| 877 Lisp_Object USED_IF_MULE (matchspec), | |
| 428 | 878 Lisp_Object domain, Lisp_Object instantiator, |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
879 Lisp_Object depth, int no_fallback) |
| 428 | 880 { |
| 881 /* When called, we're inside of call_with_suspended_errors(), | |
| 882 so we can freely error. */ | |
| 442 | 883 Lisp_Object device = DOMAIN_DEVICE (domain); |
| 428 | 884 struct device *d = XDEVICE (device); |
| 885 Lisp_Object instance; | |
| 872 | 886 Lisp_Object charset = Qnil; |
| 1204 | 887 #ifdef MULE |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
888 enum font_specifier_matchspec_stages stage = STAGE_INITIAL; |
| 428 | 889 |
| 890 if (!UNBOUNDP (matchspec)) | |
| 872 | 891 { |
| 892 charset = Fget_charset (XCAR (matchspec)); | |
| 3659 | 893 |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
894 #define FROB(new_stage, enumstage) \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
895 if (EQ(Q##new_stage, XCDR(matchspec))) \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
896 { \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
897 stage = enumstage; \ |
| 3659 | 898 } |
| 899 | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
900 FROB (initial, STAGE_INITIAL) |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
901 else FROB (final, STAGE_FINAL) |
| 3659 | 902 else assert(0); |
| 903 | |
| 904 #undef FROB | |
| 905 | |
| 872 | 906 } |
| 428 | 907 #endif |
| 908 | |
| 909 if (FONT_INSTANCEP (instantiator)) | |
| 910 { | |
| 911 if (NILP (device) | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
912 || EQ (device, XFONT_INSTANCE (instantiator)->device)) |
| 428 | 913 { |
| 914 #ifdef MULE | |
| 872 | 915 if (font_spec_matches_charset (d, charset, 0, |
| 428 | 916 Ffont_instance_truename |
| 917 (instantiator), | |
| 872 | 918 0, -1, stage)) |
| 1204 | 919 #endif |
| 428 | 920 return instantiator; |
| 921 } | |
| 922 instantiator = Ffont_instance_name (instantiator); | |
| 923 } | |
| 924 | |
| 925 if (STRINGP (instantiator)) | |
| 926 { | |
| 874 | 927 #ifdef MULE |
| 3659 | 928 /* #### rename these caches. */ |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
929 Lisp_Object cache = stage == STAGE_FINAL ? |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
930 d->charset_font_cache_stage_2 : |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
931 d->charset_font_cache_stage_1; |
| 874 | 932 #else |
| 933 Lisp_Object cache = d->font_instance_cache; | |
| 934 #endif | |
| 872 | 935 |
| 428 | 936 #ifdef MULE |
| 872 | 937 if (!NILP (charset)) |
| 428 | 938 { |
| 939 /* The instantiator is a font spec that could match many | |
| 940 different fonts. We need to find one of those fonts | |
| 941 whose registry matches the registry of the charset in | |
| 942 MATCHSPEC. This is potentially a very slow operation, | |
| 943 as it involves doing an XListFonts() or equivalent to | |
| 944 iterate over all possible fonts, and a regexp match | |
| 945 on each one. So we cache the results. */ | |
| 946 Lisp_Object matching_font = Qunbound; | |
| 872 | 947 Lisp_Object hash_table = Fgethash (charset, cache, Qunbound); |
| 428 | 948 if (UNBOUNDP (hash_table)) |
| 949 { | |
| 950 /* need to make a sub hash table. */ | |
| 951 hash_table = make_lisp_hash_table (20, HASH_TABLE_KEY_WEAK, | |
| 952 HASH_TABLE_EQUAL); | |
| 872 | 953 Fputhash (charset, hash_table, cache); |
| 428 | 954 } |
| 955 else | |
| 956 matching_font = Fgethash (instantiator, hash_table, Qunbound); | |
| 957 | |
| 958 if (UNBOUNDP (matching_font)) | |
| 959 { | |
| 960 /* make sure we cache the failures, too. */ | |
| 961 matching_font = | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
962 DEVMETH_OR_GIVEN (d, find_charset_font, |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
963 (device, instantiator, charset, stage), |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
964 instantiator); |
| 428 | 965 Fputhash (instantiator, matching_font, hash_table); |
| 966 } | |
| 967 if (NILP (matching_font)) | |
| 968 return Qunbound; | |
| 969 instantiator = matching_font; | |
| 970 } | |
| 971 #endif /* MULE */ | |
| 972 | |
| 973 /* First, look to see if we can retrieve a cached value. */ | |
| 872 | 974 instance = Fgethash (instantiator, cache, Qunbound); |
| 428 | 975 /* Otherwise, make a new one. */ |
| 976 if (UNBOUNDP (instance)) | |
| 977 { | |
| 978 /* make sure we cache the failures, too. */ | |
| 3094 | 979 instance = Fmake_font_instance (instantiator, device, Qt, charset); |
| 872 | 980 Fputhash (instantiator, instance, cache); |
| 428 | 981 } |
| 982 | |
| 983 return NILP (instance) ? Qunbound : instance; | |
| 984 } | |
| 985 else if (VECTORP (instantiator)) | |
| 986 { | |
| 3659 | 987 Lisp_Object match_inst = Qunbound; |
| 428 | 988 assert (XVECTOR_LENGTH (instantiator) == 1); |
| 3659 | 989 |
| 990 match_inst = face_property_matching_instance | |
| 991 (Fget_face (XVECTOR_DATA (instantiator)[0]), Qfont, | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
992 charset, domain, ERROR_ME, no_fallback, depth, STAGE_INITIAL); |
| 3659 | 993 |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
994 if (UNBOUNDP(match_inst)) |
| 3659 | 995 { |
| 996 match_inst = face_property_matching_instance | |
| 997 (Fget_face (XVECTOR_DATA (instantiator)[0]), Qfont, | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
4906
diff
changeset
|
998 charset, domain, ERROR_ME, no_fallback, depth, STAGE_FINAL); |
| 3659 | 999 } |
| 1000 | |
| 1001 return match_inst; | |
| 1002 | |
| 428 | 1003 } |
| 1004 else if (NILP (instantiator)) | |
| 1005 return Qunbound; | |
| 1006 else | |
| 2500 | 1007 ABORT (); /* Eh? */ |
| 428 | 1008 |
| 1009 return Qunbound; | |
| 1010 } | |
| 1011 | |
| 1012 static void | |
| 1013 font_validate (Lisp_Object instantiator) | |
| 1014 { | |
| 1015 if (FONT_INSTANCEP (instantiator) || STRINGP (instantiator)) | |
| 1016 return; | |
| 1017 if (VECTORP (instantiator)) | |
| 1018 { | |
| 1019 if (XVECTOR_LENGTH (instantiator) != 1) | |
| 1020 { | |
| 563 | 1021 sferror |
| 428 | 1022 ("Vector length must be one for font inheritance", instantiator); |
| 1023 } | |
| 1024 Fget_face (XVECTOR_DATA (instantiator)[0]); | |
| 1025 } | |
| 1026 else | |
| 563 | 1027 invalid_argument ("Must be string, vector, or font-instance", |
| 428 | 1028 instantiator); |
| 1029 } | |
| 1030 | |
| 1031 static void | |
| 1032 font_after_change (Lisp_Object specifier, Lisp_Object locale) | |
| 1033 { | |
| 1034 Lisp_Object face = FONT_SPECIFIER_FACE (XFONT_SPECIFIER (specifier)); | |
| 1035 Lisp_Object property = | |
| 1036 FONT_SPECIFIER_FACE_PROPERTY (XFONT_SPECIFIER (specifier)); | |
| 1037 if (!NILP (face)) | |
| 448 | 1038 { |
| 1039 face_property_was_changed (face, property, locale); | |
| 1040 if (BUFFERP (locale)) | |
| 1041 XBUFFER (locale)->buffer_local_face_property = 1; | |
| 1042 } | |
| 428 | 1043 } |
| 1044 | |
| 1045 void | |
| 1046 set_font_attached_to (Lisp_Object obj, Lisp_Object face, Lisp_Object property) | |
| 1047 { | |
| 440 | 1048 Lisp_Specifier *font = XFONT_SPECIFIER (obj); |
| 428 | 1049 |
| 1050 FONT_SPECIFIER_FACE (font) = face; | |
| 1051 FONT_SPECIFIER_FACE_PROPERTY (font) = property; | |
| 1052 } | |
| 1053 | |
| 1054 DEFUN ("font-specifier-p", Ffont_specifier_p, 1, 1, 0, /* | |
| 1055 Return non-nil if OBJECT is a font specifier. | |
| 1056 | |
| 442 | 1057 See `make-font-specifier' for a description of possible font instantiators. |
| 428 | 1058 */ |
| 1059 (object)) | |
| 1060 { | |
| 1061 return FONT_SPECIFIERP (object) ? Qt : Qnil; | |
| 1062 } | |
| 1063 | |
| 1064 | |
| 1065 /***************************************************************************** | |
| 1066 Face Boolean Object | |
| 1067 ****************************************************************************/ | |
| 1204 | 1068 |
| 1069 static const struct memory_description face_boolean_specifier_description[] = { | |
| 1070 { XD_LISP_OBJECT, offsetof (struct face_boolean_specifier, face) }, | |
| 1071 { XD_LISP_OBJECT, offsetof (struct face_boolean_specifier, face_property) }, | |
| 1072 { XD_END } | |
| 1073 }; | |
| 1074 | |
| 1075 DEFINE_SPECIFIER_TYPE_WITH_DATA (face_boolean); | |
| 428 | 1076 Lisp_Object Qface_boolean; |
| 1077 | |
| 1078 static void | |
| 1079 face_boolean_create (Lisp_Object obj) | |
| 1080 { | |
| 440 | 1081 Lisp_Specifier *face_boolean = XFACE_BOOLEAN_SPECIFIER (obj); |
| 428 | 1082 |
| 1083 FACE_BOOLEAN_SPECIFIER_FACE (face_boolean) = Qnil; | |
| 1084 FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY (face_boolean) = Qnil; | |
| 1085 } | |
| 1086 | |
| 1087 static void | |
| 1088 face_boolean_mark (Lisp_Object obj) | |
| 1089 { | |
| 440 | 1090 Lisp_Specifier *face_boolean = XFACE_BOOLEAN_SPECIFIER (obj); |
| 428 | 1091 |
| 1092 mark_object (FACE_BOOLEAN_SPECIFIER_FACE (face_boolean)); | |
| 1093 mark_object (FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY (face_boolean)); | |
| 1094 } | |
| 1095 | |
| 1096 /* No equal or hash methods; ignore the face the face-boolean is based off | |
| 1097 of for `equal' */ | |
| 1098 | |
| 1099 static Lisp_Object | |
| 2286 | 1100 face_boolean_instantiate (Lisp_Object specifier, |
| 1101 Lisp_Object UNUSED (matchspec), | |
| 428 | 1102 Lisp_Object domain, Lisp_Object instantiator, |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
1103 Lisp_Object depth, int no_fallback) |
| 428 | 1104 { |
| 1105 /* When called, we're inside of call_with_suspended_errors(), | |
| 1106 so we can freely error. */ | |
| 1107 if (NILP (instantiator) || EQ (instantiator, Qt)) | |
| 1108 return instantiator; | |
| 1109 else if (VECTORP (instantiator)) | |
| 1110 { | |
| 1111 Lisp_Object retval; | |
| 1112 Lisp_Object prop; | |
| 1113 int instantiator_len = XVECTOR_LENGTH (instantiator); | |
| 1114 | |
| 1115 assert (instantiator_len >= 1 && instantiator_len <= 3); | |
| 1116 if (instantiator_len > 1) | |
| 1117 prop = XVECTOR_DATA (instantiator)[1]; | |
| 1118 else | |
| 1119 { | |
| 1120 if (NILP (FACE_BOOLEAN_SPECIFIER_FACE | |
| 1121 (XFACE_BOOLEAN_SPECIFIER (specifier)))) | |
| 563 | 1122 gui_error |
| 428 | 1123 ("Face-boolean specifier not attached to a face", instantiator); |
| 1124 prop = FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY | |
| 1125 (XFACE_BOOLEAN_SPECIFIER (specifier)); | |
| 1126 } | |
| 1127 | |
| 1128 retval = (FACE_PROPERTY_INSTANCE_1 | |
| 1129 (Fget_face (XVECTOR_DATA (instantiator)[0]), | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
1130 prop, domain, ERROR_ME, no_fallback, depth)); |
| 428 | 1131 |
| 1132 if (instantiator_len == 3 && !NILP (XVECTOR_DATA (instantiator)[2])) | |
| 1133 retval = NILP (retval) ? Qt : Qnil; | |
| 1134 | |
| 1135 return retval; | |
| 1136 } | |
| 1137 else | |
| 2500 | 1138 ABORT (); /* Eh? */ |
| 428 | 1139 |
| 1140 return Qunbound; | |
| 1141 } | |
| 1142 | |
| 1143 static void | |
| 1144 face_boolean_validate (Lisp_Object instantiator) | |
| 1145 { | |
| 1146 if (NILP (instantiator) || EQ (instantiator, Qt)) | |
| 1147 return; | |
| 1148 else if (VECTORP (instantiator) && | |
| 1149 (XVECTOR_LENGTH (instantiator) >= 1 && | |
| 1150 XVECTOR_LENGTH (instantiator) <= 3)) | |
| 1151 { | |
| 1152 Lisp_Object face = XVECTOR_DATA (instantiator)[0]; | |
| 1153 | |
| 1154 Fget_face (face); | |
| 1155 | |
| 1156 if (XVECTOR_LENGTH (instantiator) > 1) | |
| 1157 { | |
| 1158 Lisp_Object field = XVECTOR_DATA (instantiator)[1]; | |
| 1159 if (!EQ (field, Qunderline) | |
| 1160 && !EQ (field, Qstrikethru) | |
| 1161 && !EQ (field, Qhighlight) | |
| 1162 && !EQ (field, Qdim) | |
| 1163 && !EQ (field, Qblinking) | |
| 1164 && !EQ (field, Qreverse)) | |
| 563 | 1165 invalid_constant ("Invalid face-boolean inheritance field", |
| 428 | 1166 field); |
| 1167 } | |
| 1168 } | |
| 1169 else if (VECTORP (instantiator)) | |
| 563 | 1170 sferror ("Wrong length for face-boolean inheritance spec", |
| 428 | 1171 instantiator); |
| 1172 else | |
| 563 | 1173 invalid_argument ("Face-boolean instantiator must be nil, t, or vector", |
| 428 | 1174 instantiator); |
| 1175 } | |
| 1176 | |
| 1177 static void | |
| 1178 face_boolean_after_change (Lisp_Object specifier, Lisp_Object locale) | |
| 1179 { | |
| 1180 Lisp_Object face = | |
| 1181 FACE_BOOLEAN_SPECIFIER_FACE (XFACE_BOOLEAN_SPECIFIER (specifier)); | |
| 1182 Lisp_Object property = | |
| 1183 FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY (XFACE_BOOLEAN_SPECIFIER (specifier)); | |
| 1184 if (!NILP (face)) | |
| 448 | 1185 { |
| 1186 face_property_was_changed (face, property, locale); | |
| 1187 if (BUFFERP (locale)) | |
| 1188 XBUFFER (locale)->buffer_local_face_property = 1; | |
| 1189 } | |
| 428 | 1190 } |
| 1191 | |
| 1192 void | |
| 1193 set_face_boolean_attached_to (Lisp_Object obj, Lisp_Object face, | |
| 1194 Lisp_Object property) | |
| 1195 { | |
| 440 | 1196 Lisp_Specifier *face_boolean = XFACE_BOOLEAN_SPECIFIER (obj); |
| 428 | 1197 |
| 1198 FACE_BOOLEAN_SPECIFIER_FACE (face_boolean) = face; | |
| 1199 FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY (face_boolean) = property; | |
| 1200 } | |
| 1201 | |
| 1202 DEFUN ("face-boolean-specifier-p", Fface_boolean_specifier_p, 1, 1, 0, /* | |
| 1203 Return non-nil if OBJECT is a face-boolean specifier. | |
| 1204 | |
| 442 | 1205 See `make-face-boolean-specifier' for a description of possible |
| 1206 face-boolean instantiators. | |
| 428 | 1207 */ |
| 1208 (object)) | |
| 1209 { | |
| 1210 return FACE_BOOLEAN_SPECIFIERP (object) ? Qt : Qnil; | |
| 1211 } | |
| 1212 | |
| 1213 | |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1214 /***************************************************************************** |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1215 Face Background Placement Object |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1216 ****************************************************************************/ |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1217 Lisp_Object Qabsolute, Qrelative; |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1218 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1219 static const struct memory_description |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1220 face_background_placement_specifier_description[] = { |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1221 { XD_LISP_OBJECT, offsetof (struct face_background_placement_specifier, |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1222 face) }, |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1223 { XD_END } |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1224 }; |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1225 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1226 DEFINE_SPECIFIER_TYPE_WITH_DATA (face_background_placement); |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1227 Lisp_Object Qface_background_placement; |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1228 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1229 static void |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1230 face_background_placement_create (Lisp_Object obj) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1231 { |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1232 Lisp_Specifier *face_background_placement |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1233 = XFACE_BACKGROUND_PLACEMENT_SPECIFIER (obj); |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1234 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1235 FACE_BACKGROUND_PLACEMENT_SPECIFIER_FACE (face_background_placement) = Qnil; |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1236 } |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1237 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1238 static void |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1239 face_background_placement_mark (Lisp_Object obj) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1240 { |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1241 Lisp_Specifier *face_background_placement |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1242 = XFACE_BACKGROUND_PLACEMENT_SPECIFIER (obj); |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1243 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1244 mark_object |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1245 (FACE_BACKGROUND_PLACEMENT_SPECIFIER_FACE (face_background_placement)); |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1246 } |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1247 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1248 /* No equal or hash methods; ignore the face the background-placement is based |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1249 off of for `equal' */ |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1250 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1251 extern Lisp_Object Qbackground_placement; |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1252 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1253 static Lisp_Object |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1254 face_background_placement_instantiate (Lisp_Object UNUSED (specifier), |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1255 Lisp_Object UNUSED (matchspec), |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1256 Lisp_Object domain, |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1257 Lisp_Object instantiator, |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1258 Lisp_Object depth, |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1259 int no_fallback) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1260 { |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1261 /* When called, we're inside of call_with_suspended_errors(), |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1262 so we can freely error. */ |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1263 if (EQ (instantiator, Qabsolute) || EQ (instantiator, Qrelative)) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1264 return instantiator; |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1265 else if (VECTORP (instantiator)) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1266 { |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1267 assert (XVECTOR_LENGTH (instantiator) == 1); |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1268 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1269 return FACE_PROPERTY_INSTANCE_1 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1270 (Fget_face (XVECTOR_DATA (instantiator)[0]), |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1271 Qbackground_placement, domain, ERROR_ME, no_fallback, depth); |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1272 } |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1273 else |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1274 ABORT (); /* Eh? */ |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1275 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1276 return Qunbound; |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1277 } |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1278 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1279 static void |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1280 face_background_placement_validate (Lisp_Object instantiator) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1281 { |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1282 if (EQ (instantiator, Qabsolute) || EQ (instantiator, Qrelative)) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1283 return; |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1284 else if (VECTORP (instantiator) && |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1285 (XVECTOR_LENGTH (instantiator) == 1)) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1286 { |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1287 Lisp_Object face = XVECTOR_DATA (instantiator)[0]; |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1288 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1289 Fget_face (face); /* just to check that the face exists -- dvl */ |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1290 } |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1291 else if (VECTORP (instantiator)) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1292 sferror ("Wrong length for background-placement inheritance spec", |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1293 instantiator); |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1294 else |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1295 invalid_argument |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1296 ("\ |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1297 Background-placement instantiator must be absolute, relative or vector", |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1298 instantiator); |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1299 } |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1300 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1301 static void |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1302 face_background_placement_after_change (Lisp_Object specifier, |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1303 Lisp_Object locale) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1304 { |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1305 Lisp_Object face |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1306 = FACE_BACKGROUND_PLACEMENT_SPECIFIER_FACE |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1307 (XFACE_BACKGROUND_PLACEMENT_SPECIFIER (specifier)); |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1308 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1309 if (!NILP (face)) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1310 { |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1311 face_property_was_changed (face, Qbackground_placement, locale); |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1312 if (BUFFERP (locale)) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1313 XBUFFER (locale)->buffer_local_face_property = 1; |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1314 } |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1315 } |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1316 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1317 void |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1318 set_face_background_placement_attached_to (Lisp_Object obj, Lisp_Object face) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1319 { |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1320 Lisp_Specifier *face_background_placement |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1321 = XFACE_BACKGROUND_PLACEMENT_SPECIFIER (obj); |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1322 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1323 FACE_BACKGROUND_PLACEMENT_SPECIFIER_FACE (face_background_placement) = face; |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1324 } |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1325 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1326 DEFUN ("face-background-placement-specifier-p", Fface_background_placement_specifier_p, 1, 1, 0, /* |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1327 Return non-nil if OBJECT is a face-background-placement specifier. |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1328 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1329 See `make-face-background-placement-specifier' for a description of possible |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1330 face-background-placement instantiators. |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1331 */ |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1332 (object)) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1333 { |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1334 return FACE_BACKGROUND_PLACEMENT_SPECIFIERP (object) ? Qt : Qnil; |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1335 } |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1336 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1337 |
| 428 | 1338 /************************************************************************/ |
| 1339 /* initialization */ | |
| 1340 /************************************************************************/ | |
| 1341 | |
| 1342 void | |
| 1343 syms_of_objects (void) | |
| 1344 { | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
1345 INIT_LISP_OBJECT (color_instance); |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
1346 INIT_LISP_OBJECT (font_instance); |
| 442 | 1347 |
| 428 | 1348 DEFSUBR (Fcolor_specifier_p); |
| 1349 DEFSUBR (Ffont_specifier_p); | |
| 1350 DEFSUBR (Fface_boolean_specifier_p); | |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1351 DEFSUBR (Fface_background_placement_specifier_p); |
| 428 | 1352 |
| 563 | 1353 DEFSYMBOL_MULTIWORD_PREDICATE (Qcolor_instancep); |
| 428 | 1354 DEFSUBR (Fmake_color_instance); |
| 1355 DEFSUBR (Fcolor_instance_p); | |
| 1356 DEFSUBR (Fcolor_instance_name); | |
| 1357 DEFSUBR (Fcolor_instance_rgb_components); | |
| 1358 DEFSUBR (Fvalid_color_name_p); | |
| 2527 | 1359 DEFSUBR (Fcolor_list); |
| 428 | 1360 |
| 563 | 1361 DEFSYMBOL_MULTIWORD_PREDICATE (Qfont_instancep); |
| 428 | 1362 DEFSUBR (Fmake_font_instance); |
| 1363 DEFSUBR (Ffont_instance_p); | |
| 1364 DEFSUBR (Ffont_instance_name); | |
| 1365 DEFSUBR (Ffont_instance_ascent); | |
| 1366 DEFSUBR (Ffont_instance_descent); | |
| 1367 DEFSUBR (Ffont_instance_width); | |
| 3094 | 1368 DEFSUBR (Ffont_instance_charset); |
| 428 | 1369 DEFSUBR (Ffont_instance_proportional_p); |
| 1370 DEFSUBR (Ffont_instance_truename); | |
| 1371 DEFSUBR (Ffont_instance_properties); | |
| 2527 | 1372 DEFSUBR (Ffont_list); |
| 428 | 1373 |
| 1374 /* Qcolor, Qfont defined in general.c */ | |
| 563 | 1375 DEFSYMBOL (Qface_boolean); |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1376 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1377 DEFSYMBOL (Qface_background_placement); |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1378 DEFSYMBOL (Qabsolute); |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1379 DEFSYMBOL (Qrelative); |
| 428 | 1380 } |
| 1381 | |
| 1382 void | |
| 1383 specifier_type_create_objects (void) | |
| 1384 { | |
| 1385 INITIALIZE_SPECIFIER_TYPE_WITH_DATA (color, "color", "color-specifier-p"); | |
| 1386 INITIALIZE_SPECIFIER_TYPE_WITH_DATA (font, "font", "font-specifier-p"); | |
| 1387 INITIALIZE_SPECIFIER_TYPE_WITH_DATA (face_boolean, "face-boolean", | |
| 1388 "face-boolean-specifier-p"); | |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1389 INITIALIZE_SPECIFIER_TYPE_WITH_DATA (face_background_placement, |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1390 "face-background-placement", |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1391 "\ |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1392 face-background-placement-specifier-p"); |
| 428 | 1393 |
| 1394 SPECIFIER_HAS_METHOD (color, instantiate); | |
| 1395 SPECIFIER_HAS_METHOD (font, instantiate); | |
| 1396 SPECIFIER_HAS_METHOD (face_boolean, instantiate); | |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1397 SPECIFIER_HAS_METHOD (face_background_placement, instantiate); |
| 428 | 1398 |
| 1399 SPECIFIER_HAS_METHOD (color, validate); | |
| 1400 SPECIFIER_HAS_METHOD (font, validate); | |
| 1401 SPECIFIER_HAS_METHOD (face_boolean, validate); | |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1402 SPECIFIER_HAS_METHOD (face_background_placement, validate); |
| 428 | 1403 |
| 1404 SPECIFIER_HAS_METHOD (color, create); | |
| 1405 SPECIFIER_HAS_METHOD (font, create); | |
| 1406 SPECIFIER_HAS_METHOD (face_boolean, create); | |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1407 SPECIFIER_HAS_METHOD (face_background_placement, create); |
| 428 | 1408 |
| 1409 SPECIFIER_HAS_METHOD (color, mark); | |
| 1410 SPECIFIER_HAS_METHOD (font, mark); | |
| 1411 SPECIFIER_HAS_METHOD (face_boolean, mark); | |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1412 SPECIFIER_HAS_METHOD (face_background_placement, mark); |
| 428 | 1413 |
| 1414 SPECIFIER_HAS_METHOD (color, after_change); | |
| 1415 SPECIFIER_HAS_METHOD (font, after_change); | |
| 1416 SPECIFIER_HAS_METHOD (face_boolean, after_change); | |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1417 SPECIFIER_HAS_METHOD (face_background_placement, after_change); |
| 428 | 1418 |
| 1419 #ifdef MULE | |
| 1420 SPECIFIER_HAS_METHOD (font, validate_matchspec); | |
| 1421 #endif | |
| 1422 } | |
| 1423 | |
| 1424 void | |
| 1425 reinit_specifier_type_create_objects (void) | |
| 1426 { | |
| 1427 REINITIALIZE_SPECIFIER_TYPE (color); | |
| 1428 REINITIALIZE_SPECIFIER_TYPE (font); | |
| 1429 REINITIALIZE_SPECIFIER_TYPE (face_boolean); | |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
5015
diff
changeset
|
1430 REINITIALIZE_SPECIFIER_TYPE (face_background_placement); |
| 428 | 1431 } |
| 1432 | |
| 1433 void | |
| 1434 reinit_vars_of_objects (void) | |
| 1435 { | |
| 1436 { | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
1437 Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (color_instance); |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
1438 Lisp_Color_Instance *c = XCOLOR_INSTANCE (obj); |
| 428 | 1439 c->name = Qnil; |
| 1440 c->device = Qnil; | |
| 1441 c->data = 0; | |
| 1442 | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
1443 Vthe_null_color_instance = obj; |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
1444 staticpro_nodump (&Vthe_null_color_instance); |
| 428 | 1445 } |
| 1446 | |
| 1447 { | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
1448 Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (font_instance); |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
1449 Lisp_Font_Instance *f = XFONT_INSTANCE (obj); |
| 428 | 1450 f->name = Qnil; |
| 872 | 1451 f->truename = Qnil; |
| 428 | 1452 f->device = Qnil; |
| 1453 f->data = 0; | |
| 1454 | |
| 1455 f->ascent = f->height = 0; | |
| 1456 f->descent = 0; | |
| 1457 f->width = 0; | |
| 1458 f->proportional_p = 0; | |
| 1459 | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
1460 Vthe_null_font_instance = obj; |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
1461 staticpro_nodump (&Vthe_null_font_instance); |
| 428 | 1462 } |
| 1463 } | |
| 1464 | |
| 1465 void | |
| 1466 vars_of_objects (void) | |
| 1467 { | |
| 1468 } |