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