Mercurial > hg > xemacs-beta
annotate src/objects.c @ 4539:061e030e3270
Fix some bugs in load-history construction, built-in symbol file names.
lib-src/ChangeLog addition:
2008-12-27 Aidan Kehoe <kehoea@parhasard.net>
* make-docfile.c (main): Allow more than one -d argument, followed
by a directory to change to.
(put_filename): Don't strip directory information; with previous
change, allows retrieval of Lisp function and variable origin
files from #'built-in-symbol-file relative to lisp-directory.
(scan_lisp_file): Don't add an extraneous newline after the file
name, put_filename has added the newline already.
lisp/ChangeLog addition:
2008-12-27 Aidan Kehoe <kehoea@parhasard.net>
* loadup.el (load-history):
Add the contents of current-load-list to load-history before
clearing it. Move the variable declarations earlier in the file to
a format understood by make-docfile.c.
* custom.el (custom-declare-variable): Add the variable's symbol
to the current file's load history entry correctly, don't use a
cons. Eliminate a comment that we don't need to worry about, we
don't need to check the `initialized' C variable in Lisp.
* bytecomp.el (byte-compile-output-file-form):
Merge Andreas Schwab's pre-GPLv3 GNU change of 19970831 here;
treat #'custom-declare-variable correctly, generating the
docstrings in a format understood by make-docfile.c.
* loadhist.el (symbol-file): Correct behaviour for checking
autoloaded macros and functions when supplied with a TYPE
argument. Accept fully-qualified paths from
#'built-in-symbol-file; if a path is not fully-qualified, return
it relative to lisp-directory if the filename corresponds to a
Lisp file, and relative to (concat source-directory "/src/")
otherwise.
* make-docfile.el (preloaded-file-list):
Rationalise some let bindings a little. Use the "-d" argument to
make-docfile.c to supply Lisp paths relative to lisp-directory,
not absolutely. Add in loadup.el explicitly to the list of files
to be processed by make-docfile.c--it doesn't make sense to add it
to preloaded-file-list, since that is used for purposes of
byte-compilation too.
src/ChangeLog addition:
2008-12-27 Aidan Kehoe <kehoea@parhasard.net>
* doc.c (Fbuilt_in_symbol_file):
Return a subr's filename immediately if we've found it. Check for
compiled function and compiled macro docstrings in DOC too, and
return them if they exist.
The branch of the if statement focused on functions may have
executed, but we may still want to check variable bindings; an
else clause isn't appropriate.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Sat, 27 Dec 2008 14:05:50 +0000 |
| parents | 515b91f904c1 |
| children | a23ac8f90a49 |
| 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 { | |
| 563 | 500 maybe_signal_error (Qgui_error, "Couldn't determine font truename", |
| 501 font_instance, Qfont, errb); | |
| 428 | 502 return Qnil; |
| 503 } | |
| 440 | 504 |
| 428 | 505 return DEVMETH_OR_GIVEN (XDEVICE (f->device), |
| 506 font_instance_truename, (f, errb), f->name); | |
| 507 } | |
| 508 | |
| 509 DEFUN ("font-instance-truename", Ffont_instance_truename, 1, 1, 0, /* | |
| 510 Return the canonical name of FONT-INSTANCE. | |
| 511 Font names are patterns which may match any number of fonts, of which | |
| 512 the first found is used. This returns an unambiguous name for that font | |
| 513 \(but not necessarily its only unambiguous name). | |
| 514 */ | |
| 515 (font_instance)) | |
| 516 { | |
| 517 CHECK_FONT_INSTANCE (font_instance); | |
| 518 return font_instance_truename_internal (font_instance, ERROR_ME); | |
| 519 } | |
| 520 | |
| 3094 | 521 DEFUN ("font-instance-charset", Ffont_instance_charset, 1, 1, 0, /* |
| 522 Return the Mule charset that FONT-INSTANCE was allocated to handle. | |
| 523 */ | |
| 524 (font_instance)) | |
| 525 { | |
| 526 CHECK_FONT_INSTANCE (font_instance); | |
| 527 return XFONT_INSTANCE (font_instance)->charset; | |
| 528 } | |
| 529 | |
| 428 | 530 DEFUN ("font-instance-properties", Ffont_instance_properties, 1, 1, 0, /* |
| 531 Return the properties (an alist or nil) of FONT-INSTANCE. | |
| 532 */ | |
| 533 (font_instance)) | |
| 534 { | |
| 440 | 535 Lisp_Font_Instance *f; |
| 428 | 536 |
| 537 CHECK_FONT_INSTANCE (font_instance); | |
| 538 f = XFONT_INSTANCE (font_instance); | |
| 539 | |
| 540 if (NILP (f->device)) | |
| 541 return Qnil; | |
| 542 | |
| 543 return MAYBE_LISP_DEVMETH (XDEVICE (f->device), | |
| 544 font_instance_properties, (f)); | |
| 545 } | |
| 546 | |
| 2527 | 547 DEFUN ("font-list", Ffont_list, 1, 3, 0, /* |
| 428 | 548 Return a list of font names matching the given pattern. |
| 549 DEVICE specifies which device to search for names, and defaults to the | |
| 550 currently selected device. | |
| 551 */ | |
| 1701 | 552 (pattern, device, maxnumber)) |
| 428 | 553 { |
| 554 CHECK_STRING (pattern); | |
| 793 | 555 device = wrap_device (decode_device (device)); |
| 428 | 556 |
| 2527 | 557 return MAYBE_LISP_DEVMETH (XDEVICE (device), font_list, (pattern, device, |
| 1701 | 558 maxnumber)); |
| 428 | 559 } |
| 560 | |
| 561 | |
| 562 /**************************************************************************** | |
| 563 Color Object | |
| 564 ***************************************************************************/ | |
| 1204 | 565 |
| 566 static const struct memory_description color_specifier_description[] = { | |
| 567 { XD_LISP_OBJECT, offsetof (struct color_specifier, face) }, | |
| 568 { XD_LISP_OBJECT, offsetof (struct color_specifier, face_property) }, | |
| 569 { XD_END } | |
| 570 }; | |
| 571 | |
| 572 DEFINE_SPECIFIER_TYPE_WITH_DATA (color); | |
| 428 | 573 /* Qcolor defined in general.c */ |
| 574 | |
| 575 static void | |
| 576 color_create (Lisp_Object obj) | |
| 577 { | |
| 440 | 578 Lisp_Specifier *color = XCOLOR_SPECIFIER (obj); |
| 428 | 579 |
| 580 COLOR_SPECIFIER_FACE (color) = Qnil; | |
| 581 COLOR_SPECIFIER_FACE_PROPERTY (color) = Qnil; | |
| 582 } | |
| 583 | |
| 584 static void | |
| 585 color_mark (Lisp_Object obj) | |
| 586 { | |
| 440 | 587 Lisp_Specifier *color = XCOLOR_SPECIFIER (obj); |
| 428 | 588 |
| 589 mark_object (COLOR_SPECIFIER_FACE (color)); | |
| 590 mark_object (COLOR_SPECIFIER_FACE_PROPERTY (color)); | |
| 591 } | |
| 592 | |
| 593 /* No equal or hash methods; ignore the face the color is based off | |
| 594 of for `equal' */ | |
| 595 | |
| 596 static Lisp_Object | |
| 2286 | 597 color_instantiate (Lisp_Object specifier, Lisp_Object UNUSED (matchspec), |
| 428 | 598 Lisp_Object domain, Lisp_Object instantiator, |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
599 Lisp_Object depth, int no_fallback) |
| 428 | 600 { |
| 601 /* When called, we're inside of call_with_suspended_errors(), | |
| 602 so we can freely error. */ | |
| 442 | 603 Lisp_Object device = DOMAIN_DEVICE (domain); |
| 428 | 604 struct device *d = XDEVICE (device); |
| 605 | |
| 606 if (COLOR_INSTANCEP (instantiator)) | |
| 607 { | |
| 608 /* 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
|
609 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
|
610 STRINGP case deal with it. */ |
| 428 | 611 if (NILP (device) /* Vthe_null_color_instance */ |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
612 || EQ (device, XCOLOR_INSTANCE (instantiator)->device)) |
| 428 | 613 return instantiator; |
| 614 else | |
| 615 instantiator = Fcolor_instance_name (instantiator); | |
| 616 } | |
| 617 | |
| 618 if (STRINGP (instantiator)) | |
| 619 { | |
| 620 /* First, look to see if we can retrieve a cached value. */ | |
| 621 Lisp_Object instance = | |
| 622 Fgethash (instantiator, d->color_instance_cache, Qunbound); | |
| 623 /* Otherwise, make a new one. */ | |
| 624 if (UNBOUNDP (instance)) | |
| 625 { | |
| 626 /* make sure we cache the failures, too. */ | |
| 627 instance = Fmake_color_instance (instantiator, device, Qt); | |
| 628 Fputhash (instantiator, instance, d->color_instance_cache); | |
| 629 } | |
| 630 | |
| 631 return NILP (instance) ? Qunbound : instance; | |
| 632 } | |
| 633 else if (VECTORP (instantiator)) | |
| 634 { | |
| 635 switch (XVECTOR_LENGTH (instantiator)) | |
| 636 { | |
| 637 case 0: | |
| 638 if (DEVICE_TTY_P (d)) | |
| 639 return Vthe_null_color_instance; | |
| 640 else | |
| 563 | 641 gui_error ("Color instantiator [] only valid on TTY's", |
| 428 | 642 device); |
| 643 | |
| 644 case 1: | |
| 645 if (NILP (COLOR_SPECIFIER_FACE (XCOLOR_SPECIFIER (specifier)))) | |
| 563 | 646 gui_error ("Color specifier not attached to a face", |
| 428 | 647 instantiator); |
| 648 return (FACE_PROPERTY_INSTANCE_1 | |
| 649 (Fget_face (XVECTOR_DATA (instantiator)[0]), | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
650 COLOR_SPECIFIER_FACE_PROPERTY |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
651 (XCOLOR_SPECIFIER (specifier)), |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
652 domain, ERROR_ME, no_fallback, depth)); |
| 428 | 653 |
| 654 case 2: | |
| 655 return (FACE_PROPERTY_INSTANCE_1 | |
| 656 (Fget_face (XVECTOR_DATA (instantiator)[0]), | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
657 XVECTOR_DATA (instantiator)[1], domain, ERROR_ME, |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
658 no_fallback, depth)); |
| 428 | 659 |
| 660 default: | |
| 2500 | 661 ABORT (); |
| 428 | 662 } |
| 663 } | |
| 664 else if (NILP (instantiator)) | |
| 665 { | |
| 666 if (DEVICE_TTY_P (d)) | |
| 667 return Vthe_null_color_instance; | |
| 668 else | |
| 563 | 669 gui_error ("Color instantiator [] only valid on TTY's", |
| 428 | 670 device); |
| 671 } | |
| 672 else | |
| 2500 | 673 ABORT (); /* The spec validation routines are screwed up. */ |
| 428 | 674 |
| 675 return Qunbound; | |
| 676 } | |
| 677 | |
| 678 static void | |
| 679 color_validate (Lisp_Object instantiator) | |
| 680 { | |
| 681 if (COLOR_INSTANCEP (instantiator) || STRINGP (instantiator)) | |
| 682 return; | |
| 683 if (VECTORP (instantiator)) | |
| 684 { | |
| 685 if (XVECTOR_LENGTH (instantiator) > 2) | |
| 563 | 686 sferror ("Inheritance vector must be of size 0 - 2", |
| 428 | 687 instantiator); |
| 688 else if (XVECTOR_LENGTH (instantiator) > 0) | |
| 689 { | |
| 690 Lisp_Object face = XVECTOR_DATA (instantiator)[0]; | |
| 691 | |
| 692 Fget_face (face); | |
| 693 if (XVECTOR_LENGTH (instantiator) == 2) | |
| 694 { | |
| 695 Lisp_Object field = XVECTOR_DATA (instantiator)[1]; | |
| 696 if (!EQ (field, Qforeground) && !EQ (field, Qbackground)) | |
| 563 | 697 invalid_constant |
| 428 | 698 ("Inheritance field must be `foreground' or `background'", |
| 699 field); | |
| 700 } | |
| 701 } | |
| 702 } | |
| 703 else | |
| 563 | 704 invalid_argument ("Invalid color instantiator", instantiator); |
| 428 | 705 } |
| 706 | |
| 707 static void | |
| 708 color_after_change (Lisp_Object specifier, Lisp_Object locale) | |
| 709 { | |
| 710 Lisp_Object face = COLOR_SPECIFIER_FACE (XCOLOR_SPECIFIER (specifier)); | |
| 711 Lisp_Object property = | |
| 712 COLOR_SPECIFIER_FACE_PROPERTY (XCOLOR_SPECIFIER (specifier)); | |
| 713 if (!NILP (face)) | |
| 448 | 714 { |
| 715 face_property_was_changed (face, property, locale); | |
| 716 if (BUFFERP (locale)) | |
| 717 XBUFFER (locale)->buffer_local_face_property = 1; | |
| 718 } | |
| 428 | 719 } |
| 720 | |
| 721 void | |
| 722 set_color_attached_to (Lisp_Object obj, Lisp_Object face, Lisp_Object property) | |
| 723 { | |
| 440 | 724 Lisp_Specifier *color = XCOLOR_SPECIFIER (obj); |
| 428 | 725 |
| 726 COLOR_SPECIFIER_FACE (color) = face; | |
| 727 COLOR_SPECIFIER_FACE_PROPERTY (color) = property; | |
| 728 } | |
| 729 | |
| 730 DEFUN ("color-specifier-p", Fcolor_specifier_p, 1, 1, 0, /* | |
| 731 Return t if OBJECT is a color specifier. | |
| 732 | |
| 442 | 733 See `make-color-specifier' for a description of possible color instantiators. |
| 428 | 734 */ |
| 735 (object)) | |
| 736 { | |
| 737 return COLOR_SPECIFIERP (object) ? Qt : Qnil; | |
| 738 } | |
| 739 | |
| 740 | |
| 741 /**************************************************************************** | |
| 742 Font Object | |
| 743 ***************************************************************************/ | |
| 1204 | 744 |
| 745 static const struct memory_description font_specifier_description[] = { | |
| 746 { XD_LISP_OBJECT, offsetof (struct font_specifier, face) }, | |
| 747 { XD_LISP_OBJECT, offsetof (struct font_specifier, face_property) }, | |
| 748 { XD_END } | |
| 749 }; | |
| 750 | |
| 751 DEFINE_SPECIFIER_TYPE_WITH_DATA (font); | |
| 428 | 752 /* Qfont defined in general.c */ |
| 753 | |
| 754 static void | |
| 755 font_create (Lisp_Object obj) | |
| 756 { | |
| 440 | 757 Lisp_Specifier *font = XFONT_SPECIFIER (obj); |
| 428 | 758 |
| 759 FONT_SPECIFIER_FACE (font) = Qnil; | |
| 760 FONT_SPECIFIER_FACE_PROPERTY (font) = Qnil; | |
| 761 } | |
| 762 | |
| 763 static void | |
| 764 font_mark (Lisp_Object obj) | |
| 765 { | |
| 440 | 766 Lisp_Specifier *font = XFONT_SPECIFIER (obj); |
| 428 | 767 |
| 768 mark_object (FONT_SPECIFIER_FACE (font)); | |
| 769 mark_object (FONT_SPECIFIER_FACE_PROPERTY (font)); | |
| 770 } | |
| 771 | |
| 772 /* No equal or hash methods; ignore the face the font is based off | |
| 773 of for `equal' */ | |
| 774 | |
| 775 #ifdef MULE | |
| 776 | |
| 872 | 777 /* Given a truename font spec (i.e. the font spec should have its registry |
| 778 field filled in), does it support displaying characters from CHARSET? */ | |
| 779 | |
| 780 static int | |
| 428 | 781 font_spec_matches_charset (struct device *d, Lisp_Object charset, |
| 867 | 782 const Ibyte *nonreloc, Lisp_Object reloc, |
| 872 | 783 Bytecount offset, Bytecount length, |
| 3659 | 784 enum font_specifier_matchspec_stages stage) |
| 428 | 785 { |
| 786 return DEVMETH_OR_GIVEN (d, font_spec_matches_charset, | |
| 872 | 787 (d, charset, nonreloc, reloc, offset, length, |
| 788 stage), | |
| 428 | 789 1); |
| 790 } | |
| 791 | |
| 792 static void | |
| 793 font_validate_matchspec (Lisp_Object matchspec) | |
| 794 { | |
| 872 | 795 CHECK_CONS (matchspec); |
| 796 Fget_charset (XCAR (matchspec)); | |
| 3659 | 797 |
| 798 do | |
| 799 { | |
| 800 if (EQ(XCDR(matchspec), Qinitial)) | |
| 801 { | |
| 802 break; | |
| 803 } | |
| 804 if (EQ(XCDR(matchspec), Qfinal)) | |
| 805 { | |
| 806 break; | |
| 807 } | |
| 808 | |
| 809 invalid_argument("Invalid font matchspec stage", | |
| 810 XCDR(matchspec)); | |
| 811 } while (0); | |
| 428 | 812 } |
| 813 | |
| 872 | 814 void |
| 815 initialize_charset_font_caches (struct device *d) | |
| 816 { | |
| 817 /* Note that the following tables are bi-level. */ | |
| 818 d->charset_font_cache_stage_1 = | |
| 819 make_lisp_hash_table (20, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); | |
| 820 d->charset_font_cache_stage_2 = | |
| 821 make_lisp_hash_table (20, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); | |
| 822 } | |
| 823 | |
| 824 void | |
| 825 invalidate_charset_font_caches (Lisp_Object charset) | |
| 826 { | |
| 827 /* Invalidate font cache entries for charset on all devices. */ | |
| 828 Lisp_Object devcons, concons, hash_table; | |
| 829 DEVICE_LOOP_NO_BREAK (devcons, concons) | |
| 830 { | |
| 831 struct device *d = XDEVICE (XCAR (devcons)); | |
| 832 hash_table = Fgethash (charset, d->charset_font_cache_stage_1, | |
| 833 Qunbound); | |
| 834 if (!UNBOUNDP (hash_table)) | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
835 Fclrhash (hash_table); |
| 872 | 836 hash_table = Fgethash (charset, d->charset_font_cache_stage_2, |
| 837 Qunbound); | |
| 838 if (!UNBOUNDP (hash_table)) | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
839 Fclrhash (hash_table); |
| 872 | 840 } |
| 841 } | |
| 428 | 842 |
| 874 | 843 #endif /* MULE */ |
| 844 | |
| 845 | |
| 428 | 846 static Lisp_Object |
| 2333 | 847 font_instantiate (Lisp_Object UNUSED (specifier), |
| 848 Lisp_Object USED_IF_MULE (matchspec), | |
| 428 | 849 Lisp_Object domain, Lisp_Object instantiator, |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
850 Lisp_Object depth, int no_fallback) |
| 428 | 851 { |
| 852 /* When called, we're inside of call_with_suspended_errors(), | |
| 853 so we can freely error. */ | |
| 442 | 854 Lisp_Object device = DOMAIN_DEVICE (domain); |
| 428 | 855 struct device *d = XDEVICE (device); |
| 856 Lisp_Object instance; | |
| 872 | 857 Lisp_Object charset = Qnil; |
| 1204 | 858 #ifdef MULE |
| 3659 | 859 enum font_specifier_matchspec_stages stage = initial; |
| 428 | 860 |
| 861 if (!UNBOUNDP (matchspec)) | |
| 872 | 862 { |
| 863 charset = Fget_charset (XCAR (matchspec)); | |
| 3659 | 864 |
| 865 #define FROB(new_stage) if (EQ(Q##new_stage, XCDR(matchspec))) \ | |
| 866 { \ | |
| 867 stage = new_stage; \ | |
| 868 } | |
| 869 | |
| 870 FROB(initial) | |
| 871 else FROB(final) | |
| 872 else assert(0); | |
| 873 | |
| 874 #undef FROB | |
| 875 | |
| 872 | 876 } |
| 428 | 877 #endif |
| 878 | |
| 879 if (FONT_INSTANCEP (instantiator)) | |
| 880 { | |
| 881 if (NILP (device) | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
882 || EQ (device, XFONT_INSTANCE (instantiator)->device)) |
| 428 | 883 { |
| 884 #ifdef MULE | |
| 872 | 885 if (font_spec_matches_charset (d, charset, 0, |
| 428 | 886 Ffont_instance_truename |
| 887 (instantiator), | |
| 872 | 888 0, -1, stage)) |
| 1204 | 889 #endif |
| 428 | 890 return instantiator; |
| 891 } | |
| 892 instantiator = Ffont_instance_name (instantiator); | |
| 893 } | |
| 894 | |
| 895 if (STRINGP (instantiator)) | |
| 896 { | |
| 874 | 897 #ifdef MULE |
| 3659 | 898 /* #### rename these caches. */ |
| 872 | 899 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
|
900 d->charset_font_cache_stage_1; |
| 874 | 901 #else |
| 902 Lisp_Object cache = d->font_instance_cache; | |
| 903 #endif | |
| 872 | 904 |
| 428 | 905 #ifdef MULE |
| 872 | 906 if (!NILP (charset)) |
| 428 | 907 { |
| 908 /* The instantiator is a font spec that could match many | |
| 909 different fonts. We need to find one of those fonts | |
| 910 whose registry matches the registry of the charset in | |
| 911 MATCHSPEC. This is potentially a very slow operation, | |
| 912 as it involves doing an XListFonts() or equivalent to | |
| 913 iterate over all possible fonts, and a regexp match | |
| 914 on each one. So we cache the results. */ | |
| 915 Lisp_Object matching_font = Qunbound; | |
| 872 | 916 Lisp_Object hash_table = Fgethash (charset, cache, Qunbound); |
| 428 | 917 if (UNBOUNDP (hash_table)) |
| 918 { | |
| 919 /* need to make a sub hash table. */ | |
| 920 hash_table = make_lisp_hash_table (20, HASH_TABLE_KEY_WEAK, | |
| 921 HASH_TABLE_EQUAL); | |
| 872 | 922 Fputhash (charset, hash_table, cache); |
| 428 | 923 } |
| 924 else | |
| 925 matching_font = Fgethash (instantiator, hash_table, Qunbound); | |
| 926 | |
| 927 if (UNBOUNDP (matching_font)) | |
| 928 { | |
| 929 /* make sure we cache the failures, too. */ | |
| 930 matching_font = | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
931 DEVMETH_OR_GIVEN (d, find_charset_font, |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
932 (device, instantiator, charset, stage), |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
933 instantiator); |
| 428 | 934 Fputhash (instantiator, matching_font, hash_table); |
| 935 } | |
| 936 if (NILP (matching_font)) | |
| 937 return Qunbound; | |
| 938 instantiator = matching_font; | |
| 939 } | |
| 940 #endif /* MULE */ | |
| 941 | |
| 942 /* First, look to see if we can retrieve a cached value. */ | |
| 872 | 943 instance = Fgethash (instantiator, cache, Qunbound); |
| 428 | 944 /* Otherwise, make a new one. */ |
| 945 if (UNBOUNDP (instance)) | |
| 946 { | |
| 947 /* make sure we cache the failures, too. */ | |
| 3094 | 948 instance = Fmake_font_instance (instantiator, device, Qt, charset); |
| 872 | 949 Fputhash (instantiator, instance, cache); |
| 428 | 950 } |
| 951 | |
| 952 return NILP (instance) ? Qunbound : instance; | |
| 953 } | |
| 954 else if (VECTORP (instantiator)) | |
| 955 { | |
| 3659 | 956 Lisp_Object match_inst = Qunbound; |
| 428 | 957 assert (XVECTOR_LENGTH (instantiator) == 1); |
| 3659 | 958 |
| 959 match_inst = face_property_matching_instance | |
| 960 (Fget_face (XVECTOR_DATA (instantiator)[0]), Qfont, | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
961 charset, domain, ERROR_ME, no_fallback, depth, initial); |
| 3659 | 962 |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
963 if (UNBOUNDP(match_inst)) |
| 3659 | 964 { |
| 965 match_inst = face_property_matching_instance | |
| 966 (Fget_face (XVECTOR_DATA (instantiator)[0]), Qfont, | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
967 charset, domain, ERROR_ME, no_fallback, depth, final); |
| 3659 | 968 } |
| 969 | |
| 970 return match_inst; | |
| 971 | |
| 428 | 972 } |
| 973 else if (NILP (instantiator)) | |
| 974 return Qunbound; | |
| 975 else | |
| 2500 | 976 ABORT (); /* Eh? */ |
| 428 | 977 |
| 978 return Qunbound; | |
| 979 } | |
| 980 | |
| 981 static void | |
| 982 font_validate (Lisp_Object instantiator) | |
| 983 { | |
| 984 if (FONT_INSTANCEP (instantiator) || STRINGP (instantiator)) | |
| 985 return; | |
| 986 if (VECTORP (instantiator)) | |
| 987 { | |
| 988 if (XVECTOR_LENGTH (instantiator) != 1) | |
| 989 { | |
| 563 | 990 sferror |
| 428 | 991 ("Vector length must be one for font inheritance", instantiator); |
| 992 } | |
| 993 Fget_face (XVECTOR_DATA (instantiator)[0]); | |
| 994 } | |
| 995 else | |
| 563 | 996 invalid_argument ("Must be string, vector, or font-instance", |
| 428 | 997 instantiator); |
| 998 } | |
| 999 | |
| 1000 static void | |
| 1001 font_after_change (Lisp_Object specifier, Lisp_Object locale) | |
| 1002 { | |
| 1003 Lisp_Object face = FONT_SPECIFIER_FACE (XFONT_SPECIFIER (specifier)); | |
| 1004 Lisp_Object property = | |
| 1005 FONT_SPECIFIER_FACE_PROPERTY (XFONT_SPECIFIER (specifier)); | |
| 1006 if (!NILP (face)) | |
| 448 | 1007 { |
| 1008 face_property_was_changed (face, property, locale); | |
| 1009 if (BUFFERP (locale)) | |
| 1010 XBUFFER (locale)->buffer_local_face_property = 1; | |
| 1011 } | |
| 428 | 1012 } |
| 1013 | |
| 1014 void | |
| 1015 set_font_attached_to (Lisp_Object obj, Lisp_Object face, Lisp_Object property) | |
| 1016 { | |
| 440 | 1017 Lisp_Specifier *font = XFONT_SPECIFIER (obj); |
| 428 | 1018 |
| 1019 FONT_SPECIFIER_FACE (font) = face; | |
| 1020 FONT_SPECIFIER_FACE_PROPERTY (font) = property; | |
| 1021 } | |
| 1022 | |
| 1023 DEFUN ("font-specifier-p", Ffont_specifier_p, 1, 1, 0, /* | |
| 1024 Return non-nil if OBJECT is a font specifier. | |
| 1025 | |
| 442 | 1026 See `make-font-specifier' for a description of possible font instantiators. |
| 428 | 1027 */ |
| 1028 (object)) | |
| 1029 { | |
| 1030 return FONT_SPECIFIERP (object) ? Qt : Qnil; | |
| 1031 } | |
| 1032 | |
| 1033 | |
| 1034 /***************************************************************************** | |
| 1035 Face Boolean Object | |
| 1036 ****************************************************************************/ | |
| 1204 | 1037 |
| 1038 static const struct memory_description face_boolean_specifier_description[] = { | |
| 1039 { XD_LISP_OBJECT, offsetof (struct face_boolean_specifier, face) }, | |
| 1040 { XD_LISP_OBJECT, offsetof (struct face_boolean_specifier, face_property) }, | |
| 1041 { XD_END } | |
| 1042 }; | |
| 1043 | |
| 1044 DEFINE_SPECIFIER_TYPE_WITH_DATA (face_boolean); | |
| 428 | 1045 Lisp_Object Qface_boolean; |
| 1046 | |
| 1047 static void | |
| 1048 face_boolean_create (Lisp_Object obj) | |
| 1049 { | |
| 440 | 1050 Lisp_Specifier *face_boolean = XFACE_BOOLEAN_SPECIFIER (obj); |
| 428 | 1051 |
| 1052 FACE_BOOLEAN_SPECIFIER_FACE (face_boolean) = Qnil; | |
| 1053 FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY (face_boolean) = Qnil; | |
| 1054 } | |
| 1055 | |
| 1056 static void | |
| 1057 face_boolean_mark (Lisp_Object obj) | |
| 1058 { | |
| 440 | 1059 Lisp_Specifier *face_boolean = XFACE_BOOLEAN_SPECIFIER (obj); |
| 428 | 1060 |
| 1061 mark_object (FACE_BOOLEAN_SPECIFIER_FACE (face_boolean)); | |
| 1062 mark_object (FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY (face_boolean)); | |
| 1063 } | |
| 1064 | |
| 1065 /* No equal or hash methods; ignore the face the face-boolean is based off | |
| 1066 of for `equal' */ | |
| 1067 | |
| 1068 static Lisp_Object | |
| 2286 | 1069 face_boolean_instantiate (Lisp_Object specifier, |
| 1070 Lisp_Object UNUSED (matchspec), | |
| 428 | 1071 Lisp_Object domain, Lisp_Object instantiator, |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
1072 Lisp_Object depth, int no_fallback) |
| 428 | 1073 { |
| 1074 /* When called, we're inside of call_with_suspended_errors(), | |
| 1075 so we can freely error. */ | |
| 1076 if (NILP (instantiator) || EQ (instantiator, Qt)) | |
| 1077 return instantiator; | |
| 1078 else if (VECTORP (instantiator)) | |
| 1079 { | |
| 1080 Lisp_Object retval; | |
| 1081 Lisp_Object prop; | |
| 1082 int instantiator_len = XVECTOR_LENGTH (instantiator); | |
| 1083 | |
| 1084 assert (instantiator_len >= 1 && instantiator_len <= 3); | |
| 1085 if (instantiator_len > 1) | |
| 1086 prop = XVECTOR_DATA (instantiator)[1]; | |
| 1087 else | |
| 1088 { | |
| 1089 if (NILP (FACE_BOOLEAN_SPECIFIER_FACE | |
| 1090 (XFACE_BOOLEAN_SPECIFIER (specifier)))) | |
| 563 | 1091 gui_error |
| 428 | 1092 ("Face-boolean specifier not attached to a face", instantiator); |
| 1093 prop = FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY | |
| 1094 (XFACE_BOOLEAN_SPECIFIER (specifier)); | |
| 1095 } | |
| 1096 | |
| 1097 retval = (FACE_PROPERTY_INSTANCE_1 | |
| 1098 (Fget_face (XVECTOR_DATA (instantiator)[0]), | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3659
diff
changeset
|
1099 prop, domain, ERROR_ME, no_fallback, depth)); |
| 428 | 1100 |
| 1101 if (instantiator_len == 3 && !NILP (XVECTOR_DATA (instantiator)[2])) | |
| 1102 retval = NILP (retval) ? Qt : Qnil; | |
| 1103 | |
| 1104 return retval; | |
| 1105 } | |
| 1106 else | |
| 2500 | 1107 ABORT (); /* Eh? */ |
| 428 | 1108 |
| 1109 return Qunbound; | |
| 1110 } | |
| 1111 | |
| 1112 static void | |
| 1113 face_boolean_validate (Lisp_Object instantiator) | |
| 1114 { | |
| 1115 if (NILP (instantiator) || EQ (instantiator, Qt)) | |
| 1116 return; | |
| 1117 else if (VECTORP (instantiator) && | |
| 1118 (XVECTOR_LENGTH (instantiator) >= 1 && | |
| 1119 XVECTOR_LENGTH (instantiator) <= 3)) | |
| 1120 { | |
| 1121 Lisp_Object face = XVECTOR_DATA (instantiator)[0]; | |
| 1122 | |
| 1123 Fget_face (face); | |
| 1124 | |
| 1125 if (XVECTOR_LENGTH (instantiator) > 1) | |
| 1126 { | |
| 1127 Lisp_Object field = XVECTOR_DATA (instantiator)[1]; | |
| 1128 if (!EQ (field, Qunderline) | |
| 1129 && !EQ (field, Qstrikethru) | |
| 1130 && !EQ (field, Qhighlight) | |
| 1131 && !EQ (field, Qdim) | |
| 1132 && !EQ (field, Qblinking) | |
| 1133 && !EQ (field, Qreverse)) | |
| 563 | 1134 invalid_constant ("Invalid face-boolean inheritance field", |
| 428 | 1135 field); |
| 1136 } | |
| 1137 } | |
| 1138 else if (VECTORP (instantiator)) | |
| 563 | 1139 sferror ("Wrong length for face-boolean inheritance spec", |
| 428 | 1140 instantiator); |
| 1141 else | |
| 563 | 1142 invalid_argument ("Face-boolean instantiator must be nil, t, or vector", |
| 428 | 1143 instantiator); |
| 1144 } | |
| 1145 | |
| 1146 static void | |
| 1147 face_boolean_after_change (Lisp_Object specifier, Lisp_Object locale) | |
| 1148 { | |
| 1149 Lisp_Object face = | |
| 1150 FACE_BOOLEAN_SPECIFIER_FACE (XFACE_BOOLEAN_SPECIFIER (specifier)); | |
| 1151 Lisp_Object property = | |
| 1152 FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY (XFACE_BOOLEAN_SPECIFIER (specifier)); | |
| 1153 if (!NILP (face)) | |
| 448 | 1154 { |
| 1155 face_property_was_changed (face, property, locale); | |
| 1156 if (BUFFERP (locale)) | |
| 1157 XBUFFER (locale)->buffer_local_face_property = 1; | |
| 1158 } | |
| 428 | 1159 } |
| 1160 | |
| 1161 void | |
| 1162 set_face_boolean_attached_to (Lisp_Object obj, Lisp_Object face, | |
| 1163 Lisp_Object property) | |
| 1164 { | |
| 440 | 1165 Lisp_Specifier *face_boolean = XFACE_BOOLEAN_SPECIFIER (obj); |
| 428 | 1166 |
| 1167 FACE_BOOLEAN_SPECIFIER_FACE (face_boolean) = face; | |
| 1168 FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY (face_boolean) = property; | |
| 1169 } | |
| 1170 | |
| 1171 DEFUN ("face-boolean-specifier-p", Fface_boolean_specifier_p, 1, 1, 0, /* | |
| 1172 Return non-nil if OBJECT is a face-boolean specifier. | |
| 1173 | |
| 442 | 1174 See `make-face-boolean-specifier' for a description of possible |
| 1175 face-boolean instantiators. | |
| 428 | 1176 */ |
| 1177 (object)) | |
| 1178 { | |
| 1179 return FACE_BOOLEAN_SPECIFIERP (object) ? Qt : Qnil; | |
| 1180 } | |
| 1181 | |
| 1182 | |
| 1183 /************************************************************************/ | |
| 1184 /* initialization */ | |
| 1185 /************************************************************************/ | |
| 1186 | |
| 1187 void | |
| 1188 syms_of_objects (void) | |
| 1189 { | |
| 442 | 1190 INIT_LRECORD_IMPLEMENTATION (color_instance); |
| 1191 INIT_LRECORD_IMPLEMENTATION (font_instance); | |
| 1192 | |
| 428 | 1193 DEFSUBR (Fcolor_specifier_p); |
| 1194 DEFSUBR (Ffont_specifier_p); | |
| 1195 DEFSUBR (Fface_boolean_specifier_p); | |
| 1196 | |
| 563 | 1197 DEFSYMBOL_MULTIWORD_PREDICATE (Qcolor_instancep); |
| 428 | 1198 DEFSUBR (Fmake_color_instance); |
| 1199 DEFSUBR (Fcolor_instance_p); | |
| 1200 DEFSUBR (Fcolor_instance_name); | |
| 1201 DEFSUBR (Fcolor_instance_rgb_components); | |
| 1202 DEFSUBR (Fvalid_color_name_p); | |
| 2527 | 1203 DEFSUBR (Fcolor_list); |
| 428 | 1204 |
| 563 | 1205 DEFSYMBOL_MULTIWORD_PREDICATE (Qfont_instancep); |
| 428 | 1206 DEFSUBR (Fmake_font_instance); |
| 1207 DEFSUBR (Ffont_instance_p); | |
| 1208 DEFSUBR (Ffont_instance_name); | |
| 1209 DEFSUBR (Ffont_instance_ascent); | |
| 1210 DEFSUBR (Ffont_instance_descent); | |
| 1211 DEFSUBR (Ffont_instance_width); | |
| 3094 | 1212 DEFSUBR (Ffont_instance_charset); |
| 428 | 1213 DEFSUBR (Ffont_instance_proportional_p); |
| 1214 DEFSUBR (Ffont_instance_truename); | |
| 1215 DEFSUBR (Ffont_instance_properties); | |
| 2527 | 1216 DEFSUBR (Ffont_list); |
| 428 | 1217 |
| 1218 /* Qcolor, Qfont defined in general.c */ | |
| 563 | 1219 DEFSYMBOL (Qface_boolean); |
| 428 | 1220 } |
| 1221 | |
| 1222 void | |
| 1223 specifier_type_create_objects (void) | |
| 1224 { | |
| 1225 INITIALIZE_SPECIFIER_TYPE_WITH_DATA (color, "color", "color-specifier-p"); | |
| 1226 INITIALIZE_SPECIFIER_TYPE_WITH_DATA (font, "font", "font-specifier-p"); | |
| 1227 INITIALIZE_SPECIFIER_TYPE_WITH_DATA (face_boolean, "face-boolean", | |
| 1228 "face-boolean-specifier-p"); | |
| 1229 | |
| 1230 SPECIFIER_HAS_METHOD (color, instantiate); | |
| 1231 SPECIFIER_HAS_METHOD (font, instantiate); | |
| 1232 SPECIFIER_HAS_METHOD (face_boolean, instantiate); | |
| 1233 | |
| 1234 SPECIFIER_HAS_METHOD (color, validate); | |
| 1235 SPECIFIER_HAS_METHOD (font, validate); | |
| 1236 SPECIFIER_HAS_METHOD (face_boolean, validate); | |
| 1237 | |
| 1238 SPECIFIER_HAS_METHOD (color, create); | |
| 1239 SPECIFIER_HAS_METHOD (font, create); | |
| 1240 SPECIFIER_HAS_METHOD (face_boolean, create); | |
| 1241 | |
| 1242 SPECIFIER_HAS_METHOD (color, mark); | |
| 1243 SPECIFIER_HAS_METHOD (font, mark); | |
| 1244 SPECIFIER_HAS_METHOD (face_boolean, mark); | |
| 1245 | |
| 1246 SPECIFIER_HAS_METHOD (color, after_change); | |
| 1247 SPECIFIER_HAS_METHOD (font, after_change); | |
| 1248 SPECIFIER_HAS_METHOD (face_boolean, after_change); | |
| 1249 | |
| 1250 #ifdef MULE | |
| 1251 SPECIFIER_HAS_METHOD (font, validate_matchspec); | |
| 1252 #endif | |
| 1253 } | |
| 1254 | |
| 1255 void | |
| 1256 reinit_specifier_type_create_objects (void) | |
| 1257 { | |
| 1258 REINITIALIZE_SPECIFIER_TYPE (color); | |
| 1259 REINITIALIZE_SPECIFIER_TYPE (font); | |
| 1260 REINITIALIZE_SPECIFIER_TYPE (face_boolean); | |
| 1261 } | |
| 1262 | |
| 1263 void | |
| 1264 reinit_vars_of_objects (void) | |
| 1265 { | |
| 1266 staticpro_nodump (&Vthe_null_color_instance); | |
| 1267 { | |
| 440 | 1268 Lisp_Color_Instance *c = |
| 3017 | 1269 ALLOC_LCRECORD_TYPE (Lisp_Color_Instance, &lrecord_color_instance); |
| 428 | 1270 c->name = Qnil; |
| 1271 c->device = Qnil; | |
| 1272 c->data = 0; | |
| 1273 | |
| 793 | 1274 Vthe_null_color_instance = wrap_color_instance (c); |
| 428 | 1275 } |
| 1276 | |
| 1277 staticpro_nodump (&Vthe_null_font_instance); | |
| 1278 { | |
| 440 | 1279 Lisp_Font_Instance *f = |
| 3017 | 1280 ALLOC_LCRECORD_TYPE (Lisp_Font_Instance, &lrecord_font_instance); |
| 428 | 1281 f->name = Qnil; |
| 872 | 1282 f->truename = Qnil; |
| 428 | 1283 f->device = Qnil; |
| 1284 f->data = 0; | |
| 1285 | |
| 1286 f->ascent = f->height = 0; | |
| 1287 f->descent = 0; | |
| 1288 f->width = 0; | |
| 1289 f->proportional_p = 0; | |
| 1290 | |
| 793 | 1291 Vthe_null_font_instance = wrap_font_instance (f); |
| 428 | 1292 } |
| 1293 } | |
| 1294 | |
| 1295 void | |
| 1296 vars_of_objects (void) | |
| 1297 { | |
| 1298 } |