Mercurial > hg > xemacs-beta
annotate src/fontcolor-gtk.c @ 5263:0d436a78c514
Add an implementation for #'the, cl-macs.el
lisp/ChangeLog addition:
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (the): Add a docstring and an implementation for this
macro.
* bytecomp.el (byte-compile-initial-macro-environment): Add #'the
to this, checking byte-compile-delete-errors to decide whether to
make the type assertion. Change the initvalue to use backquote and
preceding commas for the lambda expressions, to allow the latter
to be compiled.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Thu, 16 Sep 2010 13:36:03 +0100 |
| parents | 71ee43b8a74d |
| children | 3889ef128488 308d34e9f07d |
| rev | line source |
|---|---|
| 462 | 1 /* X-specific Lisp objects. |
| 2 Copyright (C) 1993, 1994 Free Software Foundation, Inc. | |
| 3 Copyright (C) 1995 Board of Trustees, University of Illinois. | |
| 4 Copyright (C) 1995 Tinker Systems. | |
| 872 | 5 Copyright (C) 1995, 1996, 2002 Ben Wing. |
| 462 | 6 Copyright (C) 1995 Sun Microsystems, Inc. |
| 7 | |
| 8 This file is part of XEmacs. | |
| 9 | |
| 10 XEmacs is free software; you can redistribute it and/or modify it | |
| 11 under the terms of the GNU General Public License as published by the | |
| 12 Free Software Foundation; either version 2, or (at your option) any | |
| 13 later version. | |
| 14 | |
| 15 XEmacs is distributed in the hope that it will be useful, but WITHOUT | |
| 16 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
| 17 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
| 18 for more details. | |
| 19 | |
| 20 You should have received a copy of the GNU General Public License | |
| 21 along with XEmacs; see the file COPYING. If not, write to | |
| 22 the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
| 23 Boston, MA 02111-1307, USA. */ | |
| 24 | |
| 25 /* Synched up with: Not in FSF. */ | |
| 26 | |
| 27 /* Authors: Jamie Zawinski, Chuck Thompson, Ben Wing */ | |
| 28 /* Gtk version by William Perry */ | |
| 29 | |
| 30 #include <config.h> | |
| 31 #include "lisp.h" | |
| 32 | |
| 872 | 33 #include "buffer.h" |
| 3676 | 34 #include "charset.h" |
| 872 | 35 #include "device-impl.h" |
| 36 #include "insdel.h" | |
| 462 | 37 |
| 872 | 38 #include "console-gtk-impl.h" |
|
5176
8b2f75cecb89
rename objects* (.c, .h and .el files) to fontcolor*
Ben Wing <ben@xemacs.org>
parents:
4982
diff
changeset
|
39 #include "fontcolor-gtk-impl.h" |
| 462 | 40 |
| 41 /* sigh */ | |
|
4908
b3ce27ca7647
various fixes related to gtk, redisplay-xlike-inc.c
Ben Wing <ben@xemacs.org>
parents:
3676
diff
changeset
|
42 #include "sysgdkx.h" |
| 462 | 43 |
| 3659 | 44 /* XListFonts doesn't allocate memory unconditionally based on this. (For |
| 45 XFree86 in 2005, at least. */ | |
| 46 #define MAX_FONT_COUNT INT_MAX | |
| 47 | |
| 48 #ifdef DEBUG_XEMACS | |
| 49 Fixnum debug_x_objects; | |
| 50 #endif /* DEBUG_XEMACS */ | |
| 51 | |
| 462 | 52 |
| 53 /************************************************************************/ | |
| 54 /* color instances */ | |
| 55 /************************************************************************/ | |
| 56 | |
| 57 /* Replacement for XAllocColor() that tries to return the nearest | |
| 58 available color if the colormap is full. Original was from FSFmacs, | |
| 59 but rewritten by Jareth Hein <jareth@camelot-soft.com> 97/11/25 | |
| 60 Modified by Lee Kindness <lkindness@csl.co.uk> 31/08/99 to handle previous | |
| 61 total failure which was due to a read/write colorcell being the nearest | |
| 62 match - tries the next nearest... | |
| 63 | |
| 64 Gdk takes care of all this behind the scenes, so we don't need to | |
| 65 worry about it. | |
| 66 | |
| 67 Return value is 1 for normal success, 2 for nearest color success, | |
| 68 3 for Non-deallocable sucess. */ | |
| 69 int | |
| 2286 | 70 allocate_nearest_color (GdkColormap *colormap, GdkVisual *UNUSED (visual), |
| 462 | 71 GdkColor *color_def) |
| 72 { | |
| 73 int rc; | |
| 74 | |
| 75 rc = gdk_colormap_alloc_color (colormap, color_def, FALSE, TRUE); | |
| 76 | |
| 77 if (rc == TRUE) | |
| 78 return (1); | |
| 79 | |
| 80 return (0); | |
| 81 } | |
| 82 | |
| 83 int | |
| 867 | 84 gtk_parse_nearest_color (struct device *d, GdkColor *color, Ibyte *name, |
| 578 | 85 Bytecount len, Error_Behavior errb) |
| 462 | 86 { |
| 87 GdkColormap *cmap; | |
| 88 GdkVisual *visual; | |
| 89 int result; | |
| 90 | |
| 91 cmap = DEVICE_GTK_COLORMAP(d); | |
| 92 visual = DEVICE_GTK_VISUAL (d); | |
| 93 | |
| 94 xzero (*color); | |
| 95 { | |
| 96 const Extbyte *extname; | |
| 665 | 97 Bytecount extnamelen; |
| 462 | 98 |
| 99 TO_EXTERNAL_FORMAT (DATA, (name, len), ALLOCA, (extname, extnamelen), Qbinary); | |
| 100 | |
| 101 result = gdk_color_parse (extname, color); | |
| 102 } | |
| 103 | |
| 104 if (result == FALSE) | |
| 105 { | |
| 563 | 106 maybe_invalid_argument ("unrecognized color", make_string (name, len), |
| 107 Qcolor, errb); | |
| 462 | 108 return 0; |
| 109 } | |
| 110 result = allocate_nearest_color (cmap, visual, color); | |
| 111 if (!result) | |
| 112 { | |
| 563 | 113 maybe_signal_error (Qgui_error, "couldn't allocate color", |
| 114 make_string (name, len), Qcolor, errb); | |
| 462 | 115 return 0; |
| 116 } | |
| 117 | |
| 118 return result; | |
| 119 } | |
| 120 | |
| 121 static int | |
| 122 gtk_initialize_color_instance (struct Lisp_Color_Instance *c, Lisp_Object name, | |
| 578 | 123 Lisp_Object device, Error_Behavior errb) |
| 462 | 124 { |
| 125 GdkColor color; | |
| 126 int result; | |
| 127 | |
| 128 result = gtk_parse_nearest_color (XDEVICE (device), &color, | |
| 129 XSTRING_DATA (name), | |
| 130 XSTRING_LENGTH (name), | |
| 131 errb); | |
| 132 | |
| 133 if (!result) | |
| 134 return 0; | |
| 135 | |
| 136 /* Don't allocate the data until we're sure that we will succeed, | |
| 137 or the finalize method may get fucked. */ | |
| 138 c->data = xnew (struct gtk_color_instance_data); | |
| 139 if (result == 3) | |
| 140 COLOR_INSTANCE_GTK_DEALLOC (c) = 0; | |
| 141 else | |
| 142 COLOR_INSTANCE_GTK_DEALLOC (c) = 1; | |
| 143 COLOR_INSTANCE_GTK_COLOR (c) = gdk_color_copy (&color); | |
| 144 return 1; | |
| 145 } | |
| 146 | |
| 147 static void | |
| 148 gtk_print_color_instance (struct Lisp_Color_Instance *c, | |
| 149 Lisp_Object printcharfun, | |
| 2286 | 150 int UNUSED (escapeflag)) |
| 462 | 151 { |
| 152 GdkColor *color = COLOR_INSTANCE_GTK_COLOR (c); | |
| 800 | 153 write_fmt_string (printcharfun, " %ld=(%X,%X,%X)", |
| 154 color->pixel, color->red, color->green, color->blue); | |
| 462 | 155 } |
| 156 | |
| 157 static void | |
| 158 gtk_finalize_color_instance (struct Lisp_Color_Instance *c) | |
| 159 { | |
| 160 if (c->data) | |
| 161 { | |
| 162 if (DEVICE_LIVE_P (XDEVICE (c->device))) | |
| 163 { | |
| 164 if (COLOR_INSTANCE_GTK_DEALLOC (c)) | |
| 165 { | |
| 166 gdk_colormap_free_colors (DEVICE_GTK_COLORMAP (XDEVICE (c->device)), | |
| 167 COLOR_INSTANCE_GTK_COLOR (c), 1); | |
| 168 } | |
| 169 gdk_color_free (COLOR_INSTANCE_GTK_COLOR (c)); | |
| 170 } | |
|
4976
16112448d484
Rename xfree(FOO, TYPE) -> xfree(FOO)
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
171 xfree (c->data); |
| 462 | 172 c->data = 0; |
| 173 } | |
| 174 } | |
| 175 | |
| 176 /* Color instances are equal if they resolve to the same color on the | |
| 177 screen (have the same RGB values). I imagine that | |
| 178 "same RGB values" == "same cell in the colormap." Arguably we should | |
| 179 be comparing their names or pixel values instead. */ | |
| 180 | |
| 181 static int | |
| 182 gtk_color_instance_equal (struct Lisp_Color_Instance *c1, | |
| 183 struct Lisp_Color_Instance *c2, | |
| 2286 | 184 int UNUSED (depth)) |
| 462 | 185 { |
| 186 return (gdk_color_equal (COLOR_INSTANCE_GTK_COLOR (c1), | |
| 187 COLOR_INSTANCE_GTK_COLOR (c2))); | |
| 188 } | |
| 189 | |
| 2515 | 190 static Hashcode |
|
5191
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5176
diff
changeset
|
191 gtk_color_instance_hash (struct Lisp_Color_Instance *c, int UNUSED (depth), |
|
71ee43b8a74d
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents:
5176
diff
changeset
|
192 Boolint UNUSED (equalp)) |
| 462 | 193 { |
| 194 return (gdk_color_hash (COLOR_INSTANCE_GTK_COLOR (c), NULL)); | |
| 195 } | |
| 196 | |
| 197 static Lisp_Object | |
| 198 gtk_color_instance_rgb_components (struct Lisp_Color_Instance *c) | |
| 199 { | |
| 200 GdkColor *color = COLOR_INSTANCE_GTK_COLOR (c); | |
| 201 return (list3 (make_int (color->red), | |
| 202 make_int (color->green), | |
| 203 make_int (color->blue))); | |
| 204 } | |
| 205 | |
| 206 static int | |
| 2286 | 207 gtk_valid_color_name_p (struct device *UNUSED (d), Lisp_Object color) |
| 462 | 208 { |
| 209 GdkColor c; | |
| 210 const char *extname; | |
| 211 | |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
212 extname = LISP_STRING_TO_EXTERNAL (color, Qctext); |
| 462 | 213 |
| 214 if (gdk_color_parse (extname, &c) != TRUE) | |
| 215 return(0); | |
| 216 return (1); | |
| 217 } | |
| 218 | |
| 2527 | 219 static Lisp_Object |
| 220 gtk_color_list (void) | |
| 221 { | |
| 222 /* #### BILL!!! | |
| 223 Is this correct? */ | |
| 224 return call0 (intern ("x-color-list-internal")); | |
| 225 } | |
| 226 | |
| 462 | 227 |
| 228 /************************************************************************/ | |
| 229 /* font instances */ | |
| 230 /************************************************************************/ | |
| 231 | |
| 232 static int | |
| 2286 | 233 gtk_initialize_font_instance (struct Lisp_Font_Instance *f, |
| 234 Lisp_Object UNUSED (name), | |
| 235 Lisp_Object UNUSED (device), Error_Behavior errb) | |
| 462 | 236 { |
| 237 GdkFont *gf; | |
| 238 XFontStruct *xf; | |
| 239 const char *extname; | |
| 240 | |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
241 extname = LISP_STRING_TO_EXTERNAL (f->name, Qctext); |
| 462 | 242 |
| 243 gf = gdk_font_load (extname); | |
| 244 | |
| 245 if (!gf) | |
| 246 { | |
| 563 | 247 maybe_signal_error (Qgui_error, "couldn't load font", f->name, |
| 248 Qfont, errb); | |
| 462 | 249 return 0; |
| 250 } | |
| 251 | |
| 2054 | 252 xf = (XFontStruct*) GDK_FONT_XFONT (gf); |
| 462 | 253 |
| 254 /* Don't allocate the data until we're sure that we will succeed, | |
| 255 or the finalize method may get fucked. */ | |
| 256 f->data = xnew (struct gtk_font_instance_data); | |
| 257 FONT_INSTANCE_GTK_FONT (f) = gf; | |
| 258 f->ascent = gf->ascent; | |
| 259 f->descent = gf->descent; | |
| 260 f->height = gf->ascent + gf->descent; | |
| 261 | |
| 262 /* Now lets figure out the width of the font */ | |
| 263 { | |
| 264 /* following change suggested by Ted Phelps <phelps@dstc.edu.au> */ | |
| 265 unsigned int def_char = 'n'; /*xf->default_char;*/ | |
| 266 unsigned int byte1, byte2; | |
| 267 | |
| 268 once_more: | |
| 269 byte1 = def_char >> 8; | |
| 270 byte2 = def_char & 0xFF; | |
| 271 | |
| 272 if (xf->per_char) | |
| 273 { | |
| 274 /* Old versions of the R5 font server have garbage (>63k) as | |
| 275 def_char. 'n' might not be a valid character. */ | |
| 276 if (byte1 < xf->min_byte1 || | |
| 277 byte1 > xf->max_byte1 || | |
| 278 byte2 < xf->min_char_or_byte2 || | |
| 279 byte2 > xf->max_char_or_byte2) | |
| 280 f->width = 0; | |
| 281 else | |
| 282 f->width = xf->per_char[(byte1 - xf->min_byte1) * | |
| 283 (xf->max_char_or_byte2 - | |
| 284 xf->min_char_or_byte2 + 1) + | |
| 285 (byte2 - xf->min_char_or_byte2)].width; | |
| 286 } | |
| 287 else | |
| 288 f->width = xf->max_bounds.width; | |
| 289 | |
| 290 /* Some fonts have a default char whose width is 0. This is no good. | |
| 291 If that's the case, first try 'n' as the default char, and if n has | |
| 292 0 width too (unlikely) then just use the max width. */ | |
| 293 if (f->width == 0) | |
| 294 { | |
| 295 if (def_char == xf->default_char) | |
| 296 f->width = xf->max_bounds.width; | |
| 297 else | |
| 298 { | |
| 299 def_char = xf->default_char; | |
| 300 goto once_more; | |
| 301 } | |
| 302 } | |
| 303 } | |
| 304 | |
| 305 /* If all characters don't exist then there could potentially be | |
| 306 0-width characters lurking out there. Not setting this flag | |
| 307 trips an optimization that would make them appear to have width | |
| 308 to redisplay. This is bad. So we set it if not all characters | |
| 309 have the same width or if not all characters are defined. | |
| 310 */ | |
| 311 /* #### This sucks. There is a measurable performance increase | |
| 312 when using proportional width fonts if this flag is not set. | |
| 313 Unfortunately so many of the fucking X fonts are not fully | |
| 314 defined that we could almost just get rid of this damn flag and | |
| 315 make it an assertion. */ | |
| 316 f->proportional_p = (xf->min_bounds.width != xf->max_bounds.width || | |
| 317 (/* x_handle_non_fully_specified_fonts */ 0 && | |
| 318 !xf->all_chars_exist)); | |
| 319 #if 0 | |
| 320 f->width = gdk_char_width (gf, 'n'); | |
| 321 f->proportional_p = (gdk_char_width (gf, '|') != gdk_char_width (gf, 'W')) ? 1 : 0; | |
| 322 #endif | |
| 323 return 1; | |
| 324 } | |
| 325 | |
| 326 static void | |
| 327 gtk_print_font_instance (struct Lisp_Font_Instance *f, | |
| 328 Lisp_Object printcharfun, | |
| 2286 | 329 int UNUSED (escapeflag)) |
| 462 | 330 { |
| 800 | 331 write_fmt_string (printcharfun, " 0x%lx", |
| 332 (unsigned long) gdk_font_id (FONT_INSTANCE_GTK_FONT (f))); | |
| 462 | 333 } |
| 334 | |
| 335 static void | |
| 336 gtk_finalize_font_instance (struct Lisp_Font_Instance *f) | |
| 337 { | |
| 338 if (f->data) | |
| 339 { | |
| 340 if (DEVICE_LIVE_P (XDEVICE (f->device))) | |
| 341 { | |
| 342 gdk_font_unref (FONT_INSTANCE_GTK_FONT (f)); | |
| 343 } | |
|
4976
16112448d484
Rename xfree(FOO, TYPE) -> xfree(FOO)
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
344 xfree (f->data); |
| 462 | 345 f->data = 0; |
| 346 } | |
| 347 } | |
| 348 | |
| 349 /* Forward declarations for X specific functions at the end of the file */ | |
| 350 Lisp_Object __get_gtk_font_truename (GdkFont *gdk_font, int expandp); | |
| 2527 | 351 static Lisp_Object __gtk_font_list_internal (const char *pattern); |
| 462 | 352 |
| 353 static Lisp_Object | |
| 2286 | 354 gtk_font_instance_truename (struct Lisp_Font_Instance *f, |
| 355 Error_Behavior UNUSED (errb)) | |
| 462 | 356 { |
| 872 | 357 if (NILP (FONT_INSTANCE_TRUENAME (f))) |
| 462 | 358 { |
| 872 | 359 FONT_INSTANCE_TRUENAME (f) = __get_gtk_font_truename (FONT_INSTANCE_GTK_FONT (f), 1); |
| 462 | 360 |
| 872 | 361 if (NILP (FONT_INSTANCE_TRUENAME (f))) |
| 462 | 362 { |
| 363 /* Ok, just this once, return the font name as the truename. | |
| 364 (This is only used by Fequal() right now.) */ | |
| 365 return f->name; | |
| 366 } | |
| 367 } | |
| 872 | 368 return (FONT_INSTANCE_TRUENAME (f)); |
| 462 | 369 } |
| 370 | |
| 371 static Lisp_Object | |
| 2286 | 372 gtk_font_instance_properties (struct Lisp_Font_Instance *UNUSED (f)) |
| 462 | 373 { |
| 374 Lisp_Object result = Qnil; | |
| 375 | |
| 376 /* #### BILL!!! */ | |
| 377 /* There seems to be no way to get this information under Gtk */ | |
| 378 return result; | |
| 379 } | |
| 380 | |
| 381 static Lisp_Object | |
| 2527 | 382 gtk_font_list (Lisp_Object pattern, Lisp_Object UNUSED (device), |
| 2286 | 383 Lisp_Object UNUSED (maxnumber)) |
| 462 | 384 { |
| 385 const char *patternext; | |
| 386 | |
|
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
387 patternext = LISP_STRING_TO_EXTERNAL (pattern, Qbinary); |
| 462 | 388 |
| 2527 | 389 return (__gtk_font_list_internal (patternext)); |
| 462 | 390 } |
| 391 | |
| 3659 | 392 /* Include the charset support, shared, for the moment, with X11. */ |
| 393 #define THIS_IS_GTK | |
|
5176
8b2f75cecb89
rename objects* (.c, .h and .el files) to fontcolor*
Ben Wing <ben@xemacs.org>
parents:
4982
diff
changeset
|
394 #include "fontcolor-xlike-inc.c" |
| 462 | 395 |
| 396 | |
| 397 /************************************************************************/ | |
| 398 /* initialization */ | |
| 399 /************************************************************************/ | |
| 400 | |
| 401 void | |
|
5176
8b2f75cecb89
rename objects* (.c, .h and .el files) to fontcolor*
Ben Wing <ben@xemacs.org>
parents:
4982
diff
changeset
|
402 syms_of_fontcolor_gtk (void) |
| 462 | 403 { |
| 404 } | |
| 405 | |
| 406 void | |
|
5176
8b2f75cecb89
rename objects* (.c, .h and .el files) to fontcolor*
Ben Wing <ben@xemacs.org>
parents:
4982
diff
changeset
|
407 console_type_create_fontcolor_gtk (void) |
| 462 | 408 { |
| 409 /* object methods */ | |
| 410 | |
| 411 CONSOLE_HAS_METHOD (gtk, initialize_color_instance); | |
| 412 CONSOLE_HAS_METHOD (gtk, print_color_instance); | |
| 413 CONSOLE_HAS_METHOD (gtk, finalize_color_instance); | |
| 414 CONSOLE_HAS_METHOD (gtk, color_instance_equal); | |
| 415 CONSOLE_HAS_METHOD (gtk, color_instance_hash); | |
| 416 CONSOLE_HAS_METHOD (gtk, color_instance_rgb_components); | |
| 417 CONSOLE_HAS_METHOD (gtk, valid_color_name_p); | |
| 2527 | 418 CONSOLE_HAS_METHOD (gtk, color_list); |
| 462 | 419 |
| 420 CONSOLE_HAS_METHOD (gtk, initialize_font_instance); | |
| 421 CONSOLE_HAS_METHOD (gtk, print_font_instance); | |
| 422 CONSOLE_HAS_METHOD (gtk, finalize_font_instance); | |
| 423 CONSOLE_HAS_METHOD (gtk, font_instance_truename); | |
| 424 CONSOLE_HAS_METHOD (gtk, font_instance_properties); | |
| 2527 | 425 CONSOLE_HAS_METHOD (gtk, font_list); |
| 462 | 426 #ifdef MULE |
| 427 CONSOLE_HAS_METHOD (gtk, find_charset_font); | |
| 428 CONSOLE_HAS_METHOD (gtk, font_spec_matches_charset); | |
| 429 #endif | |
| 430 } | |
| 431 | |
| 432 void | |
|
5176
8b2f75cecb89
rename objects* (.c, .h and .el files) to fontcolor*
Ben Wing <ben@xemacs.org>
parents:
4982
diff
changeset
|
433 vars_of_fontcolor_gtk (void) |
| 462 | 434 { |
| 3659 | 435 #ifdef DEBUG_XEMACS |
| 436 DEFVAR_INT ("debug-x-objects", &debug_x_objects /* | |
| 437 If non-zero, display debug information about X objects | |
| 438 */ ); | |
| 439 debug_x_objects = 0; | |
| 440 #endif | |
| 462 | 441 } |
| 442 | |
| 443 static int | |
| 444 valid_font_name_p (Display *dpy, char *name) | |
| 445 { | |
| 446 /* Maybe this should be implemented by callign XLoadFont and trapping | |
| 447 the error. That would be a lot of work, and wasteful as hell, but | |
| 448 might be more correct. | |
| 449 */ | |
| 450 int nnames = 0; | |
| 451 char **names = 0; | |
| 452 if (! name) | |
| 453 return 0; | |
| 454 names = XListFonts (dpy, name, 1, &nnames); | |
| 455 if (names) | |
| 456 XFreeFontNames (names); | |
| 457 return (nnames != 0); | |
| 458 } | |
| 459 | |
| 460 Lisp_Object | |
| 461 __get_gtk_font_truename (GdkFont *gdk_font, int expandp) | |
| 462 { | |
| 463 Display *dpy = GDK_FONT_XDISPLAY (gdk_font); | |
| 464 GSList *names = ((GdkFontPrivate *) gdk_font)->names; | |
| 465 Lisp_Object font_name = Qnil; | |
| 466 | |
| 467 while (names) | |
| 468 { | |
| 469 if (names->data) | |
| 470 { | |
| 2054 | 471 if (valid_font_name_p (dpy, (char*) names->data)) |
| 462 | 472 { |
| 473 if (!expandp) | |
| 474 { | |
| 475 /* They want the wildcarded version */ | |
|
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
3676
diff
changeset
|
476 font_name = build_cistring ((char*) names->data); |
| 462 | 477 } |
| 478 else | |
| 479 { | |
| 480 /* Need to expand out */ | |
| 481 int nnames = 0; | |
| 482 char **x_font_names = 0; | |
| 483 | |
| 2054 | 484 x_font_names = XListFonts (dpy, (char*) names->data, 1, &nnames); |
| 462 | 485 if (x_font_names) |
| 486 { | |
|
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
3676
diff
changeset
|
487 font_name = build_cistring (x_font_names[0]); |
| 462 | 488 XFreeFontNames (x_font_names); |
| 489 } | |
| 490 } | |
| 491 break; | |
| 492 } | |
| 493 } | |
| 494 names = names->next; | |
| 495 } | |
| 496 return (font_name); | |
| 497 } | |
| 498 | |
| 2527 | 499 static Lisp_Object __gtk_font_list_internal (const char *pattern) |
| 462 | 500 { |
| 501 char **names; | |
| 502 int count = 0; | |
| 503 Lisp_Object result = Qnil; | |
| 504 | |
| 505 names = XListFonts (GDK_DISPLAY (), pattern, MAX_FONT_COUNT, &count); | |
| 506 while (count--) | |
|
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
3676
diff
changeset
|
507 result = Fcons (build_extstring (names [count], Qbinary), result); |
| 462 | 508 if (names) |
| 509 XFreeFontNames (names); | |
| 510 | |
| 511 return result; | |
| 512 } |