Mercurial > hg > xemacs-beta
annotate src/objects.c @ 4903:70089046adef
fix compile problems in intl-encap* under VS6
-------------------- ChangeLog entries follow: --------------------
lib-src/ChangeLog addition:
2010-01-30 Ben Wing <ben@xemacs.org>
* make-mswin-unicode.pl:
Make it possible to specify an overridden prototype in cases where
either Cygwin or Visual Studio has errors in their headers that
can be corrected by falling back to a less qualified type (typically
without const).
src/ChangeLog addition:
2010-01-30 Ben Wing <ben@xemacs.org>
* intl-auto-encap-win32.c:
* intl-auto-encap-win32.c (qxeExtractAssociatedIcon):
* intl-auto-encap-win32.c (qxeExtractIconEx):
* intl-auto-encap-win32.c (qxeCreateMDIWindow):
* intl-auto-encap-win32.c (qxeCreateWindowStation):
* intl-auto-encap-win32.c (qxeDdeCreateStringHandle):
* intl-auto-encap-win32.c (qxeAbortSystemShutdown):
* intl-auto-encap-win32.c (qxeRegConnectRegistry):
* intl-auto-encap-win32.c (qxeGetICMProfile):
* intl-auto-encap-win32.h:
Rebuild.
* intl-encap-win32.c:
* intl-encap-win32.c (qxeUpdateICMRegKey):
Delete manual definitions of functions with former errors in
Cygwin headers but no longer. Use "override" with some functions
where Cygwin or VS6 accidentally omits a const declaration or
includes an extra one. Use "no" on SendMessageTimeout, which
has an error in the VS6 prototype (you could manually fix this
with an ifdef to split the Cygwin vs. VS6 calls, if we ever
actually used this function).
| author | Ben Wing <ben@xemacs.org> |
|---|---|
| date | Sat, 30 Jan 2010 20:34:23 -0600 |
| parents | a98ca4640147 |
| children | 6ef8256a020a |
| 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. | |
| 2527 | 4 Copyright (C) 1995, 1996, 2002, 2004 Ben Wing. |
| 428 | 5 |
| 6 This file is part of XEmacs. | |
| 7 | |
| 8 XEmacs is free software; you can redistribute it and/or modify it | |
| 9 under the terms of the GNU General Public License as published by the | |
| 10 Free Software Foundation; either version 2, or (at your option) any | |
| 11 later version. | |
| 12 | |
| 13 XEmacs is distributed in the hope that it will be useful, but WITHOUT | |
| 14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
| 15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
| 16 for more details. | |
| 17 | |
| 18 You should have received a copy of the GNU General Public License | |
| 19 along with XEmacs; see the file COPYING. If not, write to | |
| 20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
| 21 Boston, MA 02111-1307, USA. */ | |
| 22 | |
| 23 /* Synched up with: Not in FSF. */ | |
| 24 | |
| 25 #include <config.h> | |
| 26 #include "lisp.h" | |
| 27 | |
| 771 | 28 #include "buffer.h" |
| 872 | 29 #include "device-impl.h" |
| 428 | 30 #include "elhash.h" |
| 31 #include "faces.h" | |
| 32 #include "frame.h" | |
| 800 | 33 #include "glyphs.h" |
| 872 | 34 #include "objects-impl.h" |
| 428 | 35 #include "specifier.h" |
| 36 #include "window.h" | |
| 37 | |
| 1204 | 38 #ifdef HAVE_TTY |
| 39 #include "console-tty.h" | |
| 40 #endif | |
| 934 | 41 |
| 428 | 42 /* Objects that are substituted when an instantiation fails. |
| 43 If we leave in the Qunbound value, we will probably get crashes. */ | |
| 44 Lisp_Object Vthe_null_color_instance, Vthe_null_font_instance; | |
| 45 | |
| 46 /* Authors: Ben Wing, Chuck Thompson */ | |
| 47 | |
| 2268 | 48 DOESNT_RETURN |
| 428 | 49 finalose (void *ptr) |
| 50 { | |
| 793 | 51 Lisp_Object obj = wrap_pointer_1 (ptr); |
| 52 | |
| 563 | 53 invalid_operation |
| 428 | 54 ("Can't dump an emacs containing window system objects", obj); |
| 55 } | |
| 56 | |
| 57 | |
| 58 /**************************************************************************** | |
| 59 * Color-Instance Object * | |
| 60 ****************************************************************************/ | |
| 61 | |
| 62 Lisp_Object Qcolor_instancep; | |
| 63 | |
| 1204 | 64 static const struct memory_description color_instance_data_description_1 []= { |
| 65 #ifdef HAVE_TTY | |
| 3092 | 66 #ifdef NEW_GC |
| 67 { XD_LISP_OBJECT, tty_console }, | |
| 68 #else /* not NEW_GC */ | |
| 2551 | 69 { XD_BLOCK_PTR, tty_console, 1, { &tty_color_instance_data_description } }, |
| 3092 | 70 #endif /* not NEW_GC */ |
| 1204 | 71 #endif |
| 934 | 72 { XD_END } |
| 73 }; | |
| 74 | |
| 1204 | 75 static const struct sized_memory_description color_instance_data_description = { |
| 76 sizeof (void *), color_instance_data_description_1 | |
| 934 | 77 }; |
| 78 | |
| 1204 | 79 static const struct memory_description color_instance_description[] = { |
| 934 | 80 { XD_INT, offsetof (Lisp_Color_Instance, color_instance_type) }, |
| 81 { XD_LISP_OBJECT, offsetof (Lisp_Color_Instance, name)}, | |
| 82 { XD_LISP_OBJECT, offsetof (Lisp_Color_Instance, device)}, | |
| 1204 | 83 { XD_UNION, offsetof (Lisp_Color_Instance, data), |
| 2551 | 84 XD_INDIRECT (0, 0), { &color_instance_data_description } }, |
| 934 | 85 {XD_END} |
| 86 }; | |
| 87 | |
| 428 | 88 static Lisp_Object |
| 89 mark_color_instance (Lisp_Object obj) | |
| 90 { | |
| 440 | 91 Lisp_Color_Instance *c = XCOLOR_INSTANCE (obj); |
| 428 | 92 mark_object (c->name); |
| 93 if (!NILP (c->device)) /* Vthe_null_color_instance */ | |
| 94 MAYBE_DEVMETH (XDEVICE (c->device), mark_color_instance, (c)); | |
| 95 | |
| 96 return c->device; | |
| 97 } | |
| 98 | |
| 99 static void | |
| 100 print_color_instance (Lisp_Object obj, Lisp_Object printcharfun, | |
| 101 int escapeflag) | |
| 102 { | |
| 440 | 103 Lisp_Color_Instance *c = XCOLOR_INSTANCE (obj); |
| 428 | 104 if (print_readably) |
| 4846 | 105 printing_unreadable_lcrecord (obj, 0); |
| 800 | 106 write_fmt_string_lisp (printcharfun, "#<color-instance %s", 1, c->name); |
| 107 write_fmt_string_lisp (printcharfun, " on %s", 1, c->device); | |
| 428 | 108 if (!NILP (c->device)) /* Vthe_null_color_instance */ |
| 109 MAYBE_DEVMETH (XDEVICE (c->device), print_color_instance, | |
| 110 (c, printcharfun, escapeflag)); | |
| 800 | 111 write_fmt_string (printcharfun, " 0x%x>", c->header.uid); |
| 428 | 112 } |
| 113 | |
| 114 static void | |
| 115 finalize_color_instance (void *header, int for_disksave) | |
| 116 { | |
| 440 | 117 Lisp_Color_Instance *c = (Lisp_Color_Instance *) header; |
| 428 | 118 |
| 119 if (!NILP (c->device)) | |
| 120 { | |
| 121 if (for_disksave) finalose (c); | |
| 122 MAYBE_DEVMETH (XDEVICE (c->device), finalize_color_instance, (c)); | |
| 123 } | |
| 124 } | |
| 125 | |
| 126 static int | |
| 127 color_instance_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) | |
| 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 | |
| 934 | 151 DEFINE_LRECORD_IMPLEMENTATION ("color-instance", color_instance, |
| 152 0, /*dumpable-flag*/ | |
| 153 mark_color_instance, print_color_instance, | |
| 154 finalize_color_instance, color_instance_equal, | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
155 color_instance_hash, |
| 934 | 156 color_instance_description, |
| 157 Lisp_Color_Instance); | |
| 428 | 158 |
| 159 DEFUN ("make-color-instance", Fmake_color_instance, 1, 3, 0, /* | |
| 160 Return a new `color-instance' object named NAME (a string). | |
| 161 | |
| 162 Optional argument DEVICE specifies the device this object applies to | |
| 163 and defaults to the selected device. | |
| 164 | |
| 165 An error is signaled if the color is unknown or cannot be allocated; | |
| 444 | 166 however, if optional argument NOERROR is non-nil, nil is simply |
| 167 returned in this case. (And if NOERROR is other than t, a warning may | |
| 428 | 168 be issued.) |
| 169 | |
| 170 The returned object is a normal, first-class lisp object. The way you | |
| 171 `deallocate' the color is the way you deallocate any other lisp object: | |
| 172 you drop all pointers to it and allow it to be garbage collected. When | |
| 173 these objects are GCed, the underlying window-system data (e.g. X object) | |
| 174 is deallocated as well. | |
| 175 */ | |
| 444 | 176 (name, device, noerror)) |
| 428 | 177 { |
| 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 |
| 3017 | 184 c = ALLOC_LCRECORD_TYPE (Lisp_Color_Instance, &lrecord_color_instance); |
| 428 | 185 c->name = name; |
| 186 c->device = device; | |
| 187 c->data = 0; | |
| 1204 | 188 c->color_instance_type = get_console_variant (XDEVICE_TYPE (c->device)); |
| 428 | 189 |
| 190 retval = MAYBE_INT_DEVMETH (XDEVICE (device), initialize_color_instance, | |
| 191 (c, name, device, | |
| 444 | 192 decode_error_behavior_flag (noerror))); |
| 428 | 193 if (!retval) |
| 194 return Qnil; | |
| 195 | |
| 793 | 196 return wrap_color_instance (c); |
| 428 | 197 } |
| 198 | |
| 199 DEFUN ("color-instance-p", Fcolor_instance_p, 1, 1, 0, /* | |
| 200 Return non-nil if OBJECT is a color instance. | |
| 201 */ | |
| 202 (object)) | |
| 203 { | |
| 204 return COLOR_INSTANCEP (object) ? Qt : Qnil; | |
| 205 } | |
| 206 | |
| 207 DEFUN ("color-instance-name", Fcolor_instance_name, 1, 1, 0, /* | |
| 208 Return the name used to allocate COLOR-INSTANCE. | |
| 209 */ | |
| 210 (color_instance)) | |
| 211 { | |
| 212 CHECK_COLOR_INSTANCE (color_instance); | |
| 213 return XCOLOR_INSTANCE (color_instance)->name; | |
| 214 } | |
| 215 | |
| 216 DEFUN ("color-instance-rgb-components", Fcolor_instance_rgb_components, 1, 1, 0, /* | |
| 217 Return a three element list containing the red, green, and blue | |
| 218 color components of COLOR-INSTANCE, or nil if unknown. | |
| 219 Component values range from 0 to 65535. | |
| 220 */ | |
| 221 (color_instance)) | |
| 222 { | |
| 440 | 223 Lisp_Color_Instance *c; |
| 428 | 224 |
| 225 CHECK_COLOR_INSTANCE (color_instance); | |
| 226 c = XCOLOR_INSTANCE (color_instance); | |
| 227 | |
| 228 if (NILP (c->device)) | |
| 229 return Qnil; | |
| 230 | |
| 231 return MAYBE_LISP_DEVMETH (XDEVICE (c->device), | |
| 232 color_instance_rgb_components, | |
| 233 (c)); | |
| 234 } | |
| 235 | |
| 236 DEFUN ("valid-color-name-p", Fvalid_color_name_p, 1, 2, 0, /* | |
| 237 Return true if COLOR names a valid color for the current device. | |
| 238 | |
| 239 Valid color names for X are listed in the file /usr/lib/X11/rgb.txt, or | |
| 240 whatever the equivalent is on your system. | |
| 241 | |
| 242 Valid color names for TTY are those which have an ISO 6429 (ANSI) sequence. | |
| 243 In addition to being a color this may be one of a number of attributes | |
| 244 such as `blink'. | |
| 245 */ | |
| 246 (color, device)) | |
| 247 { | |
| 248 struct device *d = decode_device (device); | |
| 249 | |
| 250 CHECK_STRING (color); | |
| 251 return MAYBE_INT_DEVMETH (d, valid_color_name_p, (d, color)) ? Qt : Qnil; | |
| 252 } | |
| 253 | |
| 2527 | 254 DEFUN ("color-list", Fcolor_list, 0, 1, 0, /* |
| 255 Return a list of color names. | |
| 256 DEVICE specifies which device to return names for, and defaults to the | |
| 257 currently selected device. | |
| 258 */ | |
| 259 (device)) | |
| 260 { | |
| 261 device = wrap_device (decode_device (device)); | |
| 262 | |
| 263 return MAYBE_LISP_DEVMETH (XDEVICE (device), color_list, ()); | |
| 264 } | |
| 265 | |
| 428 | 266 |
| 267 /*************************************************************************** | |
| 268 * Font-Instance Object * | |
| 269 ***************************************************************************/ | |
| 270 | |
| 271 Lisp_Object Qfont_instancep; | |
| 272 | |
| 273 static Lisp_Object font_instance_truename_internal (Lisp_Object xfont, | |
| 578 | 274 Error_Behavior errb); |
| 934 | 275 |
| 1204 | 276 static const struct memory_description font_instance_data_description_1 []= { |
| 277 #ifdef HAVE_TTY | |
| 3092 | 278 #ifdef NEW_GC |
| 279 { XD_LISP_OBJECT, tty_console }, | |
| 280 #else /* not NEW_GC */ | |
| 281 { XD_BLOCK_PTR, tty_console, 1, { &tty_font_instance_data_description } }, | |
| 282 #endif /* not NEW_GC */ | |
| 1204 | 283 #endif |
| 934 | 284 { XD_END } |
| 285 }; | |
| 286 | |
| 1204 | 287 static const struct sized_memory_description font_instance_data_description = { |
| 288 sizeof (void *), font_instance_data_description_1 | |
| 934 | 289 }; |
| 290 | |
| 1204 | 291 static const struct memory_description font_instance_description[] = { |
| 934 | 292 { XD_INT, offsetof (Lisp_Font_Instance, font_instance_type) }, |
| 293 { XD_LISP_OBJECT, offsetof (Lisp_Font_Instance, name)}, | |
| 294 { XD_LISP_OBJECT, offsetof (Lisp_Font_Instance, truename)}, | |
| 295 { XD_LISP_OBJECT, offsetof (Lisp_Font_Instance, device)}, | |
| 3094 | 296 { XD_LISP_OBJECT, offsetof (Lisp_Font_Instance, charset)}, |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
297 { XD_UNION, offsetof (Lisp_Font_Instance, data), |
| 2551 | 298 XD_INDIRECT (0, 0), { &font_instance_data_description } }, |
| 1204 | 299 { XD_END } |
| 934 | 300 }; |
| 301 | |
| 428 | 302 |
| 303 static Lisp_Object | |
| 304 mark_font_instance (Lisp_Object obj) | |
| 305 { | |
| 440 | 306 Lisp_Font_Instance *f = XFONT_INSTANCE (obj); |
| 428 | 307 |
| 308 mark_object (f->name); | |
| 872 | 309 mark_object (f->truename); |
| 428 | 310 if (!NILP (f->device)) /* Vthe_null_font_instance */ |
| 311 MAYBE_DEVMETH (XDEVICE (f->device), mark_font_instance, (f)); | |
| 312 | |
| 313 return f->device; | |
| 314 } | |
| 315 | |
| 316 static void | |
| 317 print_font_instance (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) | |
| 318 { | |
| 440 | 319 Lisp_Font_Instance *f = XFONT_INSTANCE (obj); |
| 428 | 320 if (print_readably) |
| 4846 | 321 printing_unreadable_lcrecord (obj, 0); |
| 800 | 322 write_fmt_string_lisp (printcharfun, "#<font-instance %S", 1, f->name); |
| 323 write_fmt_string_lisp (printcharfun, " on %s", 1, f->device); | |
| 428 | 324 if (!NILP (f->device)) |
| 3659 | 325 { |
| 326 MAYBE_DEVMETH (XDEVICE (f->device), print_font_instance, | |
| 327 (f, printcharfun, escapeflag)); | |
| 328 | |
| 329 } | |
| 800 | 330 write_fmt_string (printcharfun, " 0x%x>", f->header.uid); |
| 428 | 331 } |
| 332 | |
| 333 static void | |
| 334 finalize_font_instance (void *header, int for_disksave) | |
| 335 { | |
| 440 | 336 Lisp_Font_Instance *f = (Lisp_Font_Instance *) header; |
| 428 | 337 |
| 338 if (!NILP (f->device)) | |
| 339 { | |
| 340 if (for_disksave) finalose (f); | |
| 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 | |
| 350 font_instance_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) | |
| 351 { | |
| 352 /* #### should this be moved into a device method? */ | |
| 793 | 353 return internal_equal (font_instance_truename_internal |
| 354 (obj1, ERROR_ME_DEBUG_WARN), | |
| 355 font_instance_truename_internal | |
| 356 (obj2, ERROR_ME_DEBUG_WARN), | |
| 428 | 357 depth + 1); |
| 358 } | |
| 359 | |
| 2515 | 360 static Hashcode |
| 428 | 361 font_instance_hash (Lisp_Object obj, int depth) |
| 362 { | |
| 793 | 363 return internal_hash (font_instance_truename_internal |
| 364 (obj, ERROR_ME_DEBUG_WARN), | |
| 428 | 365 depth + 1); |
| 366 } | |
| 367 | |
| 934 | 368 DEFINE_LRECORD_IMPLEMENTATION ("font-instance", font_instance, |
| 369 0, /*dumpable-flag*/ | |
| 370 mark_font_instance, print_font_instance, | |
| 371 finalize_font_instance, font_instance_equal, | |
| 1204 | 372 font_instance_hash, font_instance_description, |
| 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 { |
| 440 | 394 Lisp_Font_Instance *f; |
| 428 | 395 int retval = 0; |
| 578 | 396 Error_Behavior errb = decode_error_behavior_flag (noerror); |
| 428 | 397 |
| 398 if (ERRB_EQ (errb, ERROR_ME)) | |
| 399 CHECK_STRING (name); | |
| 400 else if (!STRINGP (name)) | |
| 401 return Qnil; | |
| 402 | |
| 793 | 403 device = wrap_device (decode_device (device)); |
| 428 | 404 |
| 3017 | 405 f = ALLOC_LCRECORD_TYPE (Lisp_Font_Instance, &lrecord_font_instance); |
| 428 | 406 f->name = name; |
| 872 | 407 f->truename = Qnil; |
| 428 | 408 f->device = device; |
| 409 | |
| 410 f->data = 0; | |
| 1204 | 411 f->font_instance_type = get_console_variant (XDEVICE_TYPE (f->device)); |
| 428 | 412 |
| 413 /* Stick some default values here ... */ | |
| 414 f->ascent = f->height = 1; | |
| 415 f->descent = 0; | |
| 416 f->width = 1; | |
| 3094 | 417 f->charset = charset; |
| 428 | 418 f->proportional_p = 0; |
| 419 | |
| 420 retval = MAYBE_INT_DEVMETH (XDEVICE (device), initialize_font_instance, | |
| 421 (f, name, device, errb)); | |
| 422 | |
| 423 if (!retval) | |
| 424 return Qnil; | |
| 425 | |
| 793 | 426 return wrap_font_instance (f); |
| 428 | 427 } |
| 428 | |
| 429 DEFUN ("font-instance-p", Ffont_instance_p, 1, 1, 0, /* | |
| 430 Return non-nil if OBJECT is a font instance. | |
| 431 */ | |
| 432 (object)) | |
| 433 { | |
| 434 return FONT_INSTANCEP (object) ? Qt : Qnil; | |
| 435 } | |
| 436 | |
| 437 DEFUN ("font-instance-name", Ffont_instance_name, 1, 1, 0, /* | |
| 438 Return the name used to allocate FONT-INSTANCE. | |
| 439 */ | |
| 440 (font_instance)) | |
| 441 { | |
| 442 CHECK_FONT_INSTANCE (font_instance); | |
| 443 return XFONT_INSTANCE (font_instance)->name; | |
| 444 } | |
| 445 | |
| 446 DEFUN ("font-instance-ascent", Ffont_instance_ascent, 1, 1, 0, /* | |
| 447 Return the ascent in pixels of FONT-INSTANCE. | |
| 448 The returned value is the maximum ascent for all characters in the font, | |
| 449 where a character's ascent is the number of pixels above (and including) | |
| 450 the baseline. | |
| 451 */ | |
| 452 (font_instance)) | |
| 453 { | |
| 454 CHECK_FONT_INSTANCE (font_instance); | |
| 455 return make_int (XFONT_INSTANCE (font_instance)->ascent); | |
| 456 } | |
| 457 | |
| 458 DEFUN ("font-instance-descent", Ffont_instance_descent, 1, 1, 0, /* | |
| 459 Return the descent in pixels of FONT-INSTANCE. | |
| 460 The returned value is the maximum descent for all characters in the font, | |
| 461 where a character's descent is the number of pixels below the baseline. | |
| 462 \(Many characters to do not have any descent. Typical characters with a | |
| 463 descent are lowercase p and lowercase g.) | |
| 464 */ | |
| 465 (font_instance)) | |
| 466 { | |
| 467 CHECK_FONT_INSTANCE (font_instance); | |
| 468 return make_int (XFONT_INSTANCE (font_instance)->descent); | |
| 469 } | |
| 470 | |
| 471 DEFUN ("font-instance-width", Ffont_instance_width, 1, 1, 0, /* | |
| 472 Return the width in pixels of FONT-INSTANCE. | |
| 473 The returned value is the average width for all characters in the font. | |
| 474 */ | |
| 475 (font_instance)) | |
| 476 { | |
| 477 CHECK_FONT_INSTANCE (font_instance); | |
| 478 return make_int (XFONT_INSTANCE (font_instance)->width); | |
| 479 } | |
| 480 | |
| 481 DEFUN ("font-instance-proportional-p", Ffont_instance_proportional_p, 1, 1, 0, /* | |
| 482 Return whether FONT-INSTANCE is proportional. | |
| 483 This means that different characters in the font have different widths. | |
| 484 */ | |
| 485 (font_instance)) | |
| 486 { | |
| 487 CHECK_FONT_INSTANCE (font_instance); | |
| 488 return XFONT_INSTANCE (font_instance)->proportional_p ? Qt : Qnil; | |
| 489 } | |
| 490 | |
| 491 static Lisp_Object | |
| 492 font_instance_truename_internal (Lisp_Object font_instance, | |
| 578 | 493 Error_Behavior errb) |
| 428 | 494 { |
| 440 | 495 Lisp_Font_Instance *f = XFONT_INSTANCE (font_instance); |
| 496 | |
| 428 | 497 if (NILP (f->device)) |
| 498 { | |
|
4757
a23ac8f90a49
Improve warning and error messages from Xft.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4426
diff
changeset
|
499 maybe_signal_error (Qgui_error, |
|
a23ac8f90a49
Improve warning and error messages from Xft.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4426
diff
changeset
|
500 "can't determine truename: " |
|
a23ac8f90a49
Improve warning and error messages from Xft.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4426
diff
changeset
|
501 "no device for font instance", |
|
a23ac8f90a49
Improve warning and error messages from Xft.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4426
diff
changeset
|
502 font_instance, Qfont, errb); |
| 428 | 503 return Qnil; |
| 504 } | |
| 440 | 505 |
| 428 | 506 return DEVMETH_OR_GIVEN (XDEVICE (f->device), |
| 507 font_instance_truename, (f, errb), f->name); | |
| 508 } | |
| 509 | |
| 510 DEFUN ("font-instance-truename", Ffont_instance_truename, 1, 1, 0, /* | |
| 511 Return the canonical name of FONT-INSTANCE. | |
| 512 Font names are patterns which may match any number of fonts, of which | |
| 513 the first found is used. This returns an unambiguous name for that font | |
| 514 \(but not necessarily its only unambiguous name). | |
| 515 */ | |
| 516 (font_instance)) | |
| 517 { | |
| 518 CHECK_FONT_INSTANCE (font_instance); | |
| 519 return font_instance_truename_internal (font_instance, ERROR_ME); | |
| 520 } | |
| 521 | |
| 3094 | 522 DEFUN ("font-instance-charset", Ffont_instance_charset, 1, 1, 0, /* |
| 523 Return the Mule charset that FONT-INSTANCE was allocated to handle. | |
| 524 */ | |
| 525 (font_instance)) | |
| 526 { | |
| 527 CHECK_FONT_INSTANCE (font_instance); | |
| 528 return XFONT_INSTANCE (font_instance)->charset; | |
| 529 } | |
| 530 | |
| 428 | 531 DEFUN ("font-instance-properties", Ffont_instance_properties, 1, 1, 0, /* |
| 532 Return the properties (an alist or nil) of FONT-INSTANCE. | |
| 533 */ | |
| 534 (font_instance)) | |
| 535 { | |
| 440 | 536 Lisp_Font_Instance *f; |
| 428 | 537 |
| 538 CHECK_FONT_INSTANCE (font_instance); | |
| 539 f = XFONT_INSTANCE (font_instance); | |
| 540 | |
| 541 if (NILP (f->device)) | |
| 542 return Qnil; | |
| 543 | |
| 544 return MAYBE_LISP_DEVMETH (XDEVICE (f->device), | |
| 545 font_instance_properties, (f)); | |
| 546 } | |
| 547 | |
| 2527 | 548 DEFUN ("font-list", Ffont_list, 1, 3, 0, /* |
| 428 | 549 Return a list of font names matching the given pattern. |
| 550 DEVICE specifies which device to search for names, and defaults to the | |
| 551 currently selected device. | |
| 552 */ | |
| 1701 | 553 (pattern, device, maxnumber)) |
| 428 | 554 { |
| 555 CHECK_STRING (pattern); | |
| 793 | 556 device = wrap_device (decode_device (device)); |
| 428 | 557 |
| 2527 | 558 return MAYBE_LISP_DEVMETH (XDEVICE (device), font_list, (pattern, device, |
| 1701 | 559 maxnumber)); |
| 428 | 560 } |
| 561 | |
| 562 | |
| 563 /**************************************************************************** | |
| 564 Color Object | |
| 565 ***************************************************************************/ | |
| 1204 | 566 |
| 567 static const struct memory_description color_specifier_description[] = { | |
| 568 { XD_LISP_OBJECT, offsetof (struct color_specifier, face) }, | |
| 569 { XD_LISP_OBJECT, offsetof (struct color_specifier, face_property) }, | |
| 570 { XD_END } | |
| 571 }; | |
| 572 | |
| 573 DEFINE_SPECIFIER_TYPE_WITH_DATA (color); | |
| 428 | 574 /* Qcolor defined in general.c */ |
| 575 | |
| 576 static void | |
| 577 color_create (Lisp_Object obj) | |
| 578 { | |
| 440 | 579 Lisp_Specifier *color = XCOLOR_SPECIFIER (obj); |
| 428 | 580 |
| 581 COLOR_SPECIFIER_FACE (color) = Qnil; | |
| 582 COLOR_SPECIFIER_FACE_PROPERTY (color) = Qnil; | |
| 583 } | |
| 584 | |
| 585 static void | |
| 586 color_mark (Lisp_Object obj) | |
| 587 { | |
| 440 | 588 Lisp_Specifier *color = XCOLOR_SPECIFIER (obj); |
| 428 | 589 |
| 590 mark_object (COLOR_SPECIFIER_FACE (color)); | |
| 591 mark_object (COLOR_SPECIFIER_FACE_PROPERTY (color)); | |
| 592 } | |
| 593 | |
| 594 /* No equal or hash methods; ignore the face the color is based off | |
| 595 of for `equal' */ | |
| 596 | |
| 597 static Lisp_Object | |
| 2286 | 598 color_instantiate (Lisp_Object specifier, Lisp_Object UNUSED (matchspec), |
| 428 | 599 Lisp_Object domain, Lisp_Object instantiator, |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
600 Lisp_Object depth, int no_fallback) |
| 428 | 601 { |
| 602 /* When called, we're inside of call_with_suspended_errors(), | |
| 603 so we can freely error. */ | |
| 442 | 604 Lisp_Object device = DOMAIN_DEVICE (domain); |
| 428 | 605 struct device *d = XDEVICE (device); |
| 606 | |
| 607 if (COLOR_INSTANCEP (instantiator)) | |
| 608 { | |
| 609 /* 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
|
610 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
|
611 STRINGP case deal with it. */ |
| 428 | 612 if (NILP (device) /* Vthe_null_color_instance */ |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
613 || EQ (device, XCOLOR_INSTANCE (instantiator)->device)) |
| 428 | 614 return instantiator; |
| 615 else | |
| 616 instantiator = Fcolor_instance_name (instantiator); | |
| 617 } | |
| 618 | |
| 619 if (STRINGP (instantiator)) | |
| 620 { | |
| 621 /* First, look to see if we can retrieve a cached value. */ | |
| 622 Lisp_Object instance = | |
| 623 Fgethash (instantiator, d->color_instance_cache, Qunbound); | |
| 624 /* Otherwise, make a new one. */ | |
| 625 if (UNBOUNDP (instance)) | |
| 626 { | |
| 627 /* make sure we cache the failures, too. */ | |
| 628 instance = Fmake_color_instance (instantiator, device, Qt); | |
| 629 Fputhash (instantiator, instance, d->color_instance_cache); | |
| 630 } | |
| 631 | |
| 632 return NILP (instance) ? Qunbound : instance; | |
| 633 } | |
| 634 else if (VECTORP (instantiator)) | |
| 635 { | |
| 636 switch (XVECTOR_LENGTH (instantiator)) | |
| 637 { | |
| 638 case 0: | |
| 639 if (DEVICE_TTY_P (d)) | |
| 640 return Vthe_null_color_instance; | |
| 641 else | |
| 563 | 642 gui_error ("Color instantiator [] only valid on TTY's", |
| 428 | 643 device); |
| 644 | |
| 645 case 1: | |
| 646 if (NILP (COLOR_SPECIFIER_FACE (XCOLOR_SPECIFIER (specifier)))) | |
| 563 | 647 gui_error ("Color specifier not attached to a face", |
| 428 | 648 instantiator); |
| 649 return (FACE_PROPERTY_INSTANCE_1 | |
| 650 (Fget_face (XVECTOR_DATA (instantiator)[0]), | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
651 COLOR_SPECIFIER_FACE_PROPERTY |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
652 (XCOLOR_SPECIFIER (specifier)), |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
653 domain, ERROR_ME, no_fallback, depth)); |
| 428 | 654 |
| 655 case 2: | |
| 656 return (FACE_PROPERTY_INSTANCE_1 | |
| 657 (Fget_face (XVECTOR_DATA (instantiator)[0]), | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
658 XVECTOR_DATA (instantiator)[1], domain, ERROR_ME, |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
659 no_fallback, depth)); |
| 428 | 660 |
| 661 default: | |
| 2500 | 662 ABORT (); |
| 428 | 663 } |
| 664 } | |
| 665 else if (NILP (instantiator)) | |
| 666 { | |
| 667 if (DEVICE_TTY_P (d)) | |
| 668 return Vthe_null_color_instance; | |
| 669 else | |
| 563 | 670 gui_error ("Color instantiator [] only valid on TTY's", |
| 428 | 671 device); |
| 672 } | |
| 673 else | |
| 2500 | 674 ABORT (); /* The spec validation routines are screwed up. */ |
| 428 | 675 |
| 676 return Qunbound; | |
| 677 } | |
| 678 | |
| 679 static void | |
| 680 color_validate (Lisp_Object instantiator) | |
| 681 { | |
| 682 if (COLOR_INSTANCEP (instantiator) || STRINGP (instantiator)) | |
| 683 return; | |
| 684 if (VECTORP (instantiator)) | |
| 685 { | |
| 686 if (XVECTOR_LENGTH (instantiator) > 2) | |
| 563 | 687 sferror ("Inheritance vector must be of size 0 - 2", |
| 428 | 688 instantiator); |
| 689 else if (XVECTOR_LENGTH (instantiator) > 0) | |
| 690 { | |
| 691 Lisp_Object face = XVECTOR_DATA (instantiator)[0]; | |
| 692 | |
| 693 Fget_face (face); | |
| 694 if (XVECTOR_LENGTH (instantiator) == 2) | |
| 695 { | |
| 696 Lisp_Object field = XVECTOR_DATA (instantiator)[1]; | |
| 697 if (!EQ (field, Qforeground) && !EQ (field, Qbackground)) | |
| 563 | 698 invalid_constant |
| 428 | 699 ("Inheritance field must be `foreground' or `background'", |
| 700 field); | |
| 701 } | |
| 702 } | |
| 703 } | |
| 704 else | |
| 563 | 705 invalid_argument ("Invalid color instantiator", instantiator); |
| 428 | 706 } |
| 707 | |
| 708 static void | |
| 709 color_after_change (Lisp_Object specifier, Lisp_Object locale) | |
| 710 { | |
| 711 Lisp_Object face = COLOR_SPECIFIER_FACE (XCOLOR_SPECIFIER (specifier)); | |
| 712 Lisp_Object property = | |
| 713 COLOR_SPECIFIER_FACE_PROPERTY (XCOLOR_SPECIFIER (specifier)); | |
| 714 if (!NILP (face)) | |
| 448 | 715 { |
| 716 face_property_was_changed (face, property, locale); | |
| 717 if (BUFFERP (locale)) | |
| 718 XBUFFER (locale)->buffer_local_face_property = 1; | |
| 719 } | |
| 428 | 720 } |
| 721 | |
| 722 void | |
| 723 set_color_attached_to (Lisp_Object obj, Lisp_Object face, Lisp_Object property) | |
| 724 { | |
| 440 | 725 Lisp_Specifier *color = XCOLOR_SPECIFIER (obj); |
| 428 | 726 |
| 727 COLOR_SPECIFIER_FACE (color) = face; | |
| 728 COLOR_SPECIFIER_FACE_PROPERTY (color) = property; | |
| 729 } | |
| 730 | |
| 731 DEFUN ("color-specifier-p", Fcolor_specifier_p, 1, 1, 0, /* | |
| 732 Return t if OBJECT is a color specifier. | |
| 733 | |
| 442 | 734 See `make-color-specifier' for a description of possible color instantiators. |
| 428 | 735 */ |
| 736 (object)) | |
| 737 { | |
| 738 return COLOR_SPECIFIERP (object) ? Qt : Qnil; | |
| 739 } | |
| 740 | |
| 741 | |
| 742 /**************************************************************************** | |
| 743 Font Object | |
| 744 ***************************************************************************/ | |
| 1204 | 745 |
| 746 static const struct memory_description font_specifier_description[] = { | |
| 747 { XD_LISP_OBJECT, offsetof (struct font_specifier, face) }, | |
| 748 { XD_LISP_OBJECT, offsetof (struct font_specifier, face_property) }, | |
| 749 { XD_END } | |
| 750 }; | |
| 751 | |
| 752 DEFINE_SPECIFIER_TYPE_WITH_DATA (font); | |
| 428 | 753 /* Qfont defined in general.c */ |
| 754 | |
| 755 static void | |
| 756 font_create (Lisp_Object obj) | |
| 757 { | |
| 440 | 758 Lisp_Specifier *font = XFONT_SPECIFIER (obj); |
| 428 | 759 |
| 760 FONT_SPECIFIER_FACE (font) = Qnil; | |
| 761 FONT_SPECIFIER_FACE_PROPERTY (font) = Qnil; | |
| 762 } | |
| 763 | |
| 764 static void | |
| 765 font_mark (Lisp_Object obj) | |
| 766 { | |
| 440 | 767 Lisp_Specifier *font = XFONT_SPECIFIER (obj); |
| 428 | 768 |
| 769 mark_object (FONT_SPECIFIER_FACE (font)); | |
| 770 mark_object (FONT_SPECIFIER_FACE_PROPERTY (font)); | |
| 771 } | |
| 772 | |
| 773 /* No equal or hash methods; ignore the face the font is based off | |
| 774 of for `equal' */ | |
| 775 | |
| 776 #ifdef MULE | |
| 777 | |
| 872 | 778 /* Given a truename font spec (i.e. the font spec should have its registry |
| 779 field filled in), does it support displaying characters from CHARSET? */ | |
| 780 | |
| 781 static int | |
| 428 | 782 font_spec_matches_charset (struct device *d, Lisp_Object charset, |
| 867 | 783 const Ibyte *nonreloc, Lisp_Object reloc, |
| 872 | 784 Bytecount offset, Bytecount length, |
| 3659 | 785 enum font_specifier_matchspec_stages stage) |
| 428 | 786 { |
| 787 return DEVMETH_OR_GIVEN (d, font_spec_matches_charset, | |
| 872 | 788 (d, charset, nonreloc, reloc, offset, length, |
| 789 stage), | |
| 428 | 790 1); |
| 791 } | |
| 792 | |
| 793 static void | |
| 794 font_validate_matchspec (Lisp_Object matchspec) | |
| 795 { | |
| 872 | 796 CHECK_CONS (matchspec); |
| 797 Fget_charset (XCAR (matchspec)); | |
| 3659 | 798 |
| 799 do | |
| 800 { | |
| 801 if (EQ(XCDR(matchspec), Qinitial)) | |
| 802 { | |
| 803 break; | |
| 804 } | |
| 805 if (EQ(XCDR(matchspec), Qfinal)) | |
| 806 { | |
| 807 break; | |
| 808 } | |
| 809 | |
| 810 invalid_argument("Invalid font matchspec stage", | |
| 811 XCDR(matchspec)); | |
| 812 } while (0); | |
| 428 | 813 } |
| 814 | |
| 872 | 815 void |
| 816 initialize_charset_font_caches (struct device *d) | |
| 817 { | |
| 818 /* Note that the following tables are bi-level. */ | |
| 819 d->charset_font_cache_stage_1 = | |
| 820 make_lisp_hash_table (20, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); | |
| 821 d->charset_font_cache_stage_2 = | |
| 822 make_lisp_hash_table (20, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); | |
| 823 } | |
| 824 | |
| 825 void | |
| 826 invalidate_charset_font_caches (Lisp_Object charset) | |
| 827 { | |
| 828 /* Invalidate font cache entries for charset on all devices. */ | |
| 829 Lisp_Object devcons, concons, hash_table; | |
| 830 DEVICE_LOOP_NO_BREAK (devcons, concons) | |
| 831 { | |
| 832 struct device *d = XDEVICE (XCAR (devcons)); | |
| 833 hash_table = Fgethash (charset, d->charset_font_cache_stage_1, | |
| 834 Qunbound); | |
| 835 if (!UNBOUNDP (hash_table)) | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
836 Fclrhash (hash_table); |
| 872 | 837 hash_table = Fgethash (charset, d->charset_font_cache_stage_2, |
| 838 Qunbound); | |
| 839 if (!UNBOUNDP (hash_table)) | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
840 Fclrhash (hash_table); |
| 872 | 841 } |
| 842 } | |
| 428 | 843 |
| 874 | 844 #endif /* MULE */ |
| 845 | |
| 846 | |
| 428 | 847 static Lisp_Object |
| 2333 | 848 font_instantiate (Lisp_Object UNUSED (specifier), |
| 849 Lisp_Object USED_IF_MULE (matchspec), | |
| 428 | 850 Lisp_Object domain, Lisp_Object instantiator, |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
851 Lisp_Object depth, int no_fallback) |
| 428 | 852 { |
| 853 /* When called, we're inside of call_with_suspended_errors(), | |
| 854 so we can freely error. */ | |
| 442 | 855 Lisp_Object device = DOMAIN_DEVICE (domain); |
| 428 | 856 struct device *d = XDEVICE (device); |
| 857 Lisp_Object instance; | |
| 872 | 858 Lisp_Object charset = Qnil; |
| 1204 | 859 #ifdef MULE |
| 3659 | 860 enum font_specifier_matchspec_stages stage = initial; |
| 428 | 861 |
| 862 if (!UNBOUNDP (matchspec)) | |
| 872 | 863 { |
| 864 charset = Fget_charset (XCAR (matchspec)); | |
| 3659 | 865 |
| 866 #define FROB(new_stage) if (EQ(Q##new_stage, XCDR(matchspec))) \ | |
| 867 { \ | |
| 868 stage = new_stage; \ | |
| 869 } | |
| 870 | |
| 871 FROB(initial) | |
| 872 else FROB(final) | |
| 873 else assert(0); | |
| 874 | |
| 875 #undef FROB | |
| 876 | |
| 872 | 877 } |
| 428 | 878 #endif |
| 879 | |
| 880 if (FONT_INSTANCEP (instantiator)) | |
| 881 { | |
| 882 if (NILP (device) | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
883 || EQ (device, XFONT_INSTANCE (instantiator)->device)) |
| 428 | 884 { |
| 885 #ifdef MULE | |
| 872 | 886 if (font_spec_matches_charset (d, charset, 0, |
| 428 | 887 Ffont_instance_truename |
| 888 (instantiator), | |
| 872 | 889 0, -1, stage)) |
| 1204 | 890 #endif |
| 428 | 891 return instantiator; |
| 892 } | |
| 893 instantiator = Ffont_instance_name (instantiator); | |
| 894 } | |
| 895 | |
| 896 if (STRINGP (instantiator)) | |
| 897 { | |
| 874 | 898 #ifdef MULE |
| 3659 | 899 /* #### rename these caches. */ |
| 872 | 900 Lisp_Object cache = stage ? d->charset_font_cache_stage_2 : |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
901 d->charset_font_cache_stage_1; |
| 874 | 902 #else |
| 903 Lisp_Object cache = d->font_instance_cache; | |
| 904 #endif | |
| 872 | 905 |
| 428 | 906 #ifdef MULE |
| 872 | 907 if (!NILP (charset)) |
| 428 | 908 { |
| 909 /* The instantiator is a font spec that could match many | |
| 910 different fonts. We need to find one of those fonts | |
| 911 whose registry matches the registry of the charset in | |
| 912 MATCHSPEC. This is potentially a very slow operation, | |
| 913 as it involves doing an XListFonts() or equivalent to | |
| 914 iterate over all possible fonts, and a regexp match | |
| 915 on each one. So we cache the results. */ | |
| 916 Lisp_Object matching_font = Qunbound; | |
| 872 | 917 Lisp_Object hash_table = Fgethash (charset, cache, Qunbound); |
| 428 | 918 if (UNBOUNDP (hash_table)) |
| 919 { | |
| 920 /* need to make a sub hash table. */ | |
| 921 hash_table = make_lisp_hash_table (20, HASH_TABLE_KEY_WEAK, | |
| 922 HASH_TABLE_EQUAL); | |
| 872 | 923 Fputhash (charset, hash_table, cache); |
| 428 | 924 } |
| 925 else | |
| 926 matching_font = Fgethash (instantiator, hash_table, Qunbound); | |
| 927 | |
| 928 if (UNBOUNDP (matching_font)) | |
| 929 { | |
| 930 /* make sure we cache the failures, too. */ | |
| 931 matching_font = | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
932 DEVMETH_OR_GIVEN (d, find_charset_font, |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
933 (device, instantiator, charset, stage), |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
934 instantiator); |
| 428 | 935 Fputhash (instantiator, matching_font, hash_table); |
| 936 } | |
| 937 if (NILP (matching_font)) | |
| 938 return Qunbound; | |
| 939 instantiator = matching_font; | |
| 940 } | |
| 941 #endif /* MULE */ | |
| 942 | |
| 943 /* First, look to see if we can retrieve a cached value. */ | |
| 872 | 944 instance = Fgethash (instantiator, cache, Qunbound); |
| 428 | 945 /* Otherwise, make a new one. */ |
| 946 if (UNBOUNDP (instance)) | |
| 947 { | |
| 948 /* make sure we cache the failures, too. */ | |
| 3094 | 949 instance = Fmake_font_instance (instantiator, device, Qt, charset); |
| 872 | 950 Fputhash (instantiator, instance, cache); |
| 428 | 951 } |
| 952 | |
| 953 return NILP (instance) ? Qunbound : instance; | |
| 954 } | |
| 955 else if (VECTORP (instantiator)) | |
| 956 { | |
| 3659 | 957 Lisp_Object match_inst = Qunbound; |
| 428 | 958 assert (XVECTOR_LENGTH (instantiator) == 1); |
| 3659 | 959 |
| 960 match_inst = face_property_matching_instance | |
| 961 (Fget_face (XVECTOR_DATA (instantiator)[0]), Qfont, | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
962 charset, domain, ERROR_ME, no_fallback, depth, initial); |
| 3659 | 963 |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
964 if (UNBOUNDP(match_inst)) |
| 3659 | 965 { |
| 966 match_inst = face_property_matching_instance | |
| 967 (Fget_face (XVECTOR_DATA (instantiator)[0]), Qfont, | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
968 charset, domain, ERROR_ME, no_fallback, depth, final); |
| 3659 | 969 } |
| 970 | |
| 971 return match_inst; | |
| 972 | |
| 428 | 973 } |
| 974 else if (NILP (instantiator)) | |
| 975 return Qunbound; | |
| 976 else | |
| 2500 | 977 ABORT (); /* Eh? */ |
| 428 | 978 |
| 979 return Qunbound; | |
| 980 } | |
| 981 | |
| 982 static void | |
| 983 font_validate (Lisp_Object instantiator) | |
| 984 { | |
| 985 if (FONT_INSTANCEP (instantiator) || STRINGP (instantiator)) | |
| 986 return; | |
| 987 if (VECTORP (instantiator)) | |
| 988 { | |
| 989 if (XVECTOR_LENGTH (instantiator) != 1) | |
| 990 { | |
| 563 | 991 sferror |
| 428 | 992 ("Vector length must be one for font inheritance", instantiator); |
| 993 } | |
| 994 Fget_face (XVECTOR_DATA (instantiator)[0]); | |
| 995 } | |
| 996 else | |
| 563 | 997 invalid_argument ("Must be string, vector, or font-instance", |
| 428 | 998 instantiator); |
| 999 } | |
| 1000 | |
| 1001 static void | |
| 1002 font_after_change (Lisp_Object specifier, Lisp_Object locale) | |
| 1003 { | |
| 1004 Lisp_Object face = FONT_SPECIFIER_FACE (XFONT_SPECIFIER (specifier)); | |
| 1005 Lisp_Object property = | |
| 1006 FONT_SPECIFIER_FACE_PROPERTY (XFONT_SPECIFIER (specifier)); | |
| 1007 if (!NILP (face)) | |
| 448 | 1008 { |
| 1009 face_property_was_changed (face, property, locale); | |
| 1010 if (BUFFERP (locale)) | |
| 1011 XBUFFER (locale)->buffer_local_face_property = 1; | |
| 1012 } | |
| 428 | 1013 } |
| 1014 | |
| 1015 void | |
| 1016 set_font_attached_to (Lisp_Object obj, Lisp_Object face, Lisp_Object property) | |
| 1017 { | |
| 440 | 1018 Lisp_Specifier *font = XFONT_SPECIFIER (obj); |
| 428 | 1019 |
| 1020 FONT_SPECIFIER_FACE (font) = face; | |
| 1021 FONT_SPECIFIER_FACE_PROPERTY (font) = property; | |
| 1022 } | |
| 1023 | |
| 1024 DEFUN ("font-specifier-p", Ffont_specifier_p, 1, 1, 0, /* | |
| 1025 Return non-nil if OBJECT is a font specifier. | |
| 1026 | |
| 442 | 1027 See `make-font-specifier' for a description of possible font instantiators. |
| 428 | 1028 */ |
| 1029 (object)) | |
| 1030 { | |
| 1031 return FONT_SPECIFIERP (object) ? Qt : Qnil; | |
| 1032 } | |
| 1033 | |
| 1034 | |
| 1035 /***************************************************************************** | |
| 1036 Face Boolean Object | |
| 1037 ****************************************************************************/ | |
| 1204 | 1038 |
| 1039 static const struct memory_description face_boolean_specifier_description[] = { | |
| 1040 { XD_LISP_OBJECT, offsetof (struct face_boolean_specifier, face) }, | |
| 1041 { XD_LISP_OBJECT, offsetof (struct face_boolean_specifier, face_property) }, | |
| 1042 { XD_END } | |
| 1043 }; | |
| 1044 | |
| 1045 DEFINE_SPECIFIER_TYPE_WITH_DATA (face_boolean); | |
| 428 | 1046 Lisp_Object Qface_boolean; |
| 1047 | |
| 1048 static void | |
| 1049 face_boolean_create (Lisp_Object obj) | |
| 1050 { | |
| 440 | 1051 Lisp_Specifier *face_boolean = XFACE_BOOLEAN_SPECIFIER (obj); |
| 428 | 1052 |
| 1053 FACE_BOOLEAN_SPECIFIER_FACE (face_boolean) = Qnil; | |
| 1054 FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY (face_boolean) = Qnil; | |
| 1055 } | |
| 1056 | |
| 1057 static void | |
| 1058 face_boolean_mark (Lisp_Object obj) | |
| 1059 { | |
| 440 | 1060 Lisp_Specifier *face_boolean = XFACE_BOOLEAN_SPECIFIER (obj); |
| 428 | 1061 |
| 1062 mark_object (FACE_BOOLEAN_SPECIFIER_FACE (face_boolean)); | |
| 1063 mark_object (FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY (face_boolean)); | |
| 1064 } | |
| 1065 | |
| 1066 /* No equal or hash methods; ignore the face the face-boolean is based off | |
| 1067 of for `equal' */ | |
| 1068 | |
| 1069 static Lisp_Object | |
| 2286 | 1070 face_boolean_instantiate (Lisp_Object specifier, |
| 1071 Lisp_Object UNUSED (matchspec), | |
| 428 | 1072 Lisp_Object domain, Lisp_Object instantiator, |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
1073 Lisp_Object depth, int no_fallback) |
| 428 | 1074 { |
| 1075 /* When called, we're inside of call_with_suspended_errors(), | |
| 1076 so we can freely error. */ | |
| 1077 if (NILP (instantiator) || EQ (instantiator, Qt)) | |
| 1078 return instantiator; | |
| 1079 else if (VECTORP (instantiator)) | |
| 1080 { | |
| 1081 Lisp_Object retval; | |
| 1082 Lisp_Object prop; | |
| 1083 int instantiator_len = XVECTOR_LENGTH (instantiator); | |
| 1084 | |
| 1085 assert (instantiator_len >= 1 && instantiator_len <= 3); | |
| 1086 if (instantiator_len > 1) | |
| 1087 prop = XVECTOR_DATA (instantiator)[1]; | |
| 1088 else | |
| 1089 { | |
| 1090 if (NILP (FACE_BOOLEAN_SPECIFIER_FACE | |
| 1091 (XFACE_BOOLEAN_SPECIFIER (specifier)))) | |
| 563 | 1092 gui_error |
| 428 | 1093 ("Face-boolean specifier not attached to a face", instantiator); |
| 1094 prop = FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY | |
| 1095 (XFACE_BOOLEAN_SPECIFIER (specifier)); | |
| 1096 } | |
| 1097 | |
| 1098 retval = (FACE_PROPERTY_INSTANCE_1 | |
| 1099 (Fget_face (XVECTOR_DATA (instantiator)[0]), | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
1100 prop, domain, ERROR_ME, no_fallback, depth)); |
| 428 | 1101 |
| 1102 if (instantiator_len == 3 && !NILP (XVECTOR_DATA (instantiator)[2])) | |
| 1103 retval = NILP (retval) ? Qt : Qnil; | |
| 1104 | |
| 1105 return retval; | |
| 1106 } | |
| 1107 else | |
| 2500 | 1108 ABORT (); /* Eh? */ |
| 428 | 1109 |
| 1110 return Qunbound; | |
| 1111 } | |
| 1112 | |
| 1113 static void | |
| 1114 face_boolean_validate (Lisp_Object instantiator) | |
| 1115 { | |
| 1116 if (NILP (instantiator) || EQ (instantiator, Qt)) | |
| 1117 return; | |
| 1118 else if (VECTORP (instantiator) && | |
| 1119 (XVECTOR_LENGTH (instantiator) >= 1 && | |
| 1120 XVECTOR_LENGTH (instantiator) <= 3)) | |
| 1121 { | |
| 1122 Lisp_Object face = XVECTOR_DATA (instantiator)[0]; | |
| 1123 | |
| 1124 Fget_face (face); | |
| 1125 | |
| 1126 if (XVECTOR_LENGTH (instantiator) > 1) | |
| 1127 { | |
| 1128 Lisp_Object field = XVECTOR_DATA (instantiator)[1]; | |
| 1129 if (!EQ (field, Qunderline) | |
| 1130 && !EQ (field, Qstrikethru) | |
| 1131 && !EQ (field, Qhighlight) | |
| 1132 && !EQ (field, Qdim) | |
| 1133 && !EQ (field, Qblinking) | |
| 1134 && !EQ (field, Qreverse)) | |
| 563 | 1135 invalid_constant ("Invalid face-boolean inheritance field", |
| 428 | 1136 field); |
| 1137 } | |
| 1138 } | |
| 1139 else if (VECTORP (instantiator)) | |
| 563 | 1140 sferror ("Wrong length for face-boolean inheritance spec", |
| 428 | 1141 instantiator); |
| 1142 else | |
| 563 | 1143 invalid_argument ("Face-boolean instantiator must be nil, t, or vector", |
| 428 | 1144 instantiator); |
| 1145 } | |
| 1146 | |
| 1147 static void | |
| 1148 face_boolean_after_change (Lisp_Object specifier, Lisp_Object locale) | |
| 1149 { | |
| 1150 Lisp_Object face = | |
| 1151 FACE_BOOLEAN_SPECIFIER_FACE (XFACE_BOOLEAN_SPECIFIER (specifier)); | |
| 1152 Lisp_Object property = | |
| 1153 FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY (XFACE_BOOLEAN_SPECIFIER (specifier)); | |
| 1154 if (!NILP (face)) | |
| 448 | 1155 { |
| 1156 face_property_was_changed (face, property, locale); | |
| 1157 if (BUFFERP (locale)) | |
| 1158 XBUFFER (locale)->buffer_local_face_property = 1; | |
| 1159 } | |
| 428 | 1160 } |
| 1161 | |
| 1162 void | |
| 1163 set_face_boolean_attached_to (Lisp_Object obj, Lisp_Object face, | |
| 1164 Lisp_Object property) | |
| 1165 { | |
| 440 | 1166 Lisp_Specifier *face_boolean = XFACE_BOOLEAN_SPECIFIER (obj); |
| 428 | 1167 |
| 1168 FACE_BOOLEAN_SPECIFIER_FACE (face_boolean) = face; | |
| 1169 FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY (face_boolean) = property; | |
| 1170 } | |
| 1171 | |
| 1172 DEFUN ("face-boolean-specifier-p", Fface_boolean_specifier_p, 1, 1, 0, /* | |
| 1173 Return non-nil if OBJECT is a face-boolean specifier. | |
| 1174 | |
| 442 | 1175 See `make-face-boolean-specifier' for a description of possible |
| 1176 face-boolean instantiators. | |
| 428 | 1177 */ |
| 1178 (object)) | |
| 1179 { | |
| 1180 return FACE_BOOLEAN_SPECIFIERP (object) ? Qt : Qnil; | |
| 1181 } | |
| 1182 | |
| 1183 | |
| 1184 /************************************************************************/ | |
| 1185 /* initialization */ | |
| 1186 /************************************************************************/ | |
| 1187 | |
| 1188 void | |
| 1189 syms_of_objects (void) | |
| 1190 { | |
| 442 | 1191 INIT_LRECORD_IMPLEMENTATION (color_instance); |
| 1192 INIT_LRECORD_IMPLEMENTATION (font_instance); | |
| 1193 | |
| 428 | 1194 DEFSUBR (Fcolor_specifier_p); |
| 1195 DEFSUBR (Ffont_specifier_p); | |
| 1196 DEFSUBR (Fface_boolean_specifier_p); | |
| 1197 | |
| 563 | 1198 DEFSYMBOL_MULTIWORD_PREDICATE (Qcolor_instancep); |
| 428 | 1199 DEFSUBR (Fmake_color_instance); |
| 1200 DEFSUBR (Fcolor_instance_p); | |
| 1201 DEFSUBR (Fcolor_instance_name); | |
| 1202 DEFSUBR (Fcolor_instance_rgb_components); | |
| 1203 DEFSUBR (Fvalid_color_name_p); | |
| 2527 | 1204 DEFSUBR (Fcolor_list); |
| 428 | 1205 |
| 563 | 1206 DEFSYMBOL_MULTIWORD_PREDICATE (Qfont_instancep); |
| 428 | 1207 DEFSUBR (Fmake_font_instance); |
| 1208 DEFSUBR (Ffont_instance_p); | |
| 1209 DEFSUBR (Ffont_instance_name); | |
| 1210 DEFSUBR (Ffont_instance_ascent); | |
| 1211 DEFSUBR (Ffont_instance_descent); | |
| 1212 DEFSUBR (Ffont_instance_width); | |
| 3094 | 1213 DEFSUBR (Ffont_instance_charset); |
| 428 | 1214 DEFSUBR (Ffont_instance_proportional_p); |
| 1215 DEFSUBR (Ffont_instance_truename); | |
| 1216 DEFSUBR (Ffont_instance_properties); | |
| 2527 | 1217 DEFSUBR (Ffont_list); |
| 428 | 1218 |
| 1219 /* Qcolor, Qfont defined in general.c */ | |
| 563 | 1220 DEFSYMBOL (Qface_boolean); |
| 428 | 1221 } |
| 1222 | |
| 1223 void | |
| 1224 specifier_type_create_objects (void) | |
| 1225 { | |
| 1226 INITIALIZE_SPECIFIER_TYPE_WITH_DATA (color, "color", "color-specifier-p"); | |
| 1227 INITIALIZE_SPECIFIER_TYPE_WITH_DATA (font, "font", "font-specifier-p"); | |
| 1228 INITIALIZE_SPECIFIER_TYPE_WITH_DATA (face_boolean, "face-boolean", | |
| 1229 "face-boolean-specifier-p"); | |
| 1230 | |
| 1231 SPECIFIER_HAS_METHOD (color, instantiate); | |
| 1232 SPECIFIER_HAS_METHOD (font, instantiate); | |
| 1233 SPECIFIER_HAS_METHOD (face_boolean, instantiate); | |
| 1234 | |
| 1235 SPECIFIER_HAS_METHOD (color, validate); | |
| 1236 SPECIFIER_HAS_METHOD (font, validate); | |
| 1237 SPECIFIER_HAS_METHOD (face_boolean, validate); | |
| 1238 | |
| 1239 SPECIFIER_HAS_METHOD (color, create); | |
| 1240 SPECIFIER_HAS_METHOD (font, create); | |
| 1241 SPECIFIER_HAS_METHOD (face_boolean, create); | |
| 1242 | |
| 1243 SPECIFIER_HAS_METHOD (color, mark); | |
| 1244 SPECIFIER_HAS_METHOD (font, mark); | |
| 1245 SPECIFIER_HAS_METHOD (face_boolean, mark); | |
| 1246 | |
| 1247 SPECIFIER_HAS_METHOD (color, after_change); | |
| 1248 SPECIFIER_HAS_METHOD (font, after_change); | |
| 1249 SPECIFIER_HAS_METHOD (face_boolean, after_change); | |
| 1250 | |
| 1251 #ifdef MULE | |
| 1252 SPECIFIER_HAS_METHOD (font, validate_matchspec); | |
| 1253 #endif | |
| 1254 } | |
| 1255 | |
| 1256 void | |
| 1257 reinit_specifier_type_create_objects (void) | |
| 1258 { | |
| 1259 REINITIALIZE_SPECIFIER_TYPE (color); | |
| 1260 REINITIALIZE_SPECIFIER_TYPE (font); | |
| 1261 REINITIALIZE_SPECIFIER_TYPE (face_boolean); | |
| 1262 } | |
| 1263 | |
| 1264 void | |
| 1265 reinit_vars_of_objects (void) | |
| 1266 { | |
| 1267 staticpro_nodump (&Vthe_null_color_instance); | |
| 1268 { | |
| 440 | 1269 Lisp_Color_Instance *c = |
| 3017 | 1270 ALLOC_LCRECORD_TYPE (Lisp_Color_Instance, &lrecord_color_instance); |
| 428 | 1271 c->name = Qnil; |
| 1272 c->device = Qnil; | |
| 1273 c->data = 0; | |
| 1274 | |
| 793 | 1275 Vthe_null_color_instance = wrap_color_instance (c); |
| 428 | 1276 } |
| 1277 | |
| 1278 staticpro_nodump (&Vthe_null_font_instance); | |
| 1279 { | |
| 440 | 1280 Lisp_Font_Instance *f = |
| 3017 | 1281 ALLOC_LCRECORD_TYPE (Lisp_Font_Instance, &lrecord_font_instance); |
| 428 | 1282 f->name = Qnil; |
| 872 | 1283 f->truename = Qnil; |
| 428 | 1284 f->device = Qnil; |
| 1285 f->data = 0; | |
| 1286 | |
| 1287 f->ascent = f->height = 0; | |
| 1288 f->descent = 0; | |
| 1289 f->width = 0; | |
| 1290 f->proportional_p = 0; | |
| 1291 | |
| 793 | 1292 Vthe_null_font_instance = wrap_font_instance (f); |
| 428 | 1293 } |
| 1294 } | |
| 1295 | |
| 1296 void | |
| 1297 vars_of_objects (void) | |
| 1298 { | |
| 1299 } |