Mercurial > hg > xemacs-beta

comparison src/fontcolor.c @ 5176:8b2f75cecb89

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