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