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