Mercurial > hg > xemacs-beta

comparison src/objects.c @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children ac2d302a0011
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
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 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 "device.h"
29 #include "elhash.h"
30 #include "faces.h"
31 #include "frame.h"
32 #include "objects.h"
33 #include "specifier.h"
34 #include "window.h"
35
36 /* Objects that are substituted when an instantiation fails.
37 If we leave in the Qunbound value, we will probably get crashes. */
38 Lisp_Object Vthe_null_color_instance, Vthe_null_font_instance;
39
40 /* Authors: Ben Wing, Chuck Thompson */
41
42 void
43 finalose (void *ptr)
44 {
45 Lisp_Object obj;
46 XSETOBJ (obj, Lisp_Record, ptr);
47
48 signal_simple_error
49 ("Can't dump an emacs containing window system objects", obj);
50 }
51
52
53 /****************************************************************************
54 * Color-Instance Object *
55 ****************************************************************************/
56
57 Lisp_Object Qcolor_instancep;
58 static Lisp_Object mark_color_instance (Lisp_Object, void (*) (Lisp_Object));
59 static void print_color_instance (Lisp_Object, Lisp_Object, int);
60 static void finalize_color_instance (void *, int);
61 static int color_instance_equal (Lisp_Object, Lisp_Object, int depth);
62 static unsigned long color_instance_hash (Lisp_Object obj, int depth);
63 DEFINE_LRECORD_IMPLEMENTATION ("color-instance", color_instance,
64 mark_color_instance, print_color_instance,
65 finalize_color_instance, color_instance_equal,
66 color_instance_hash,
67 struct Lisp_Color_Instance);
68
69 static Lisp_Object
70 mark_color_instance (Lisp_Object obj, void (*markobj) (Lisp_Object))
71 {
72 struct Lisp_Color_Instance *c = XCOLOR_INSTANCE (obj);
73 ((markobj) (c->name));
74 if (!NILP (c->device)) /* Vthe_null_color_instance */
75 MAYBE_DEVMETH (XDEVICE (c->device), mark_color_instance, (c, markobj));
76
77 return (c->device);
78 }
79
80 static void
81 print_color_instance (Lisp_Object obj, Lisp_Object printcharfun,
82 int escapeflag)
83 {
84 char buf[100];
85 struct Lisp_Color_Instance *c = XCOLOR_INSTANCE (obj);
86 if (print_readably)
87 error ("printing unreadable object #<color-instance 0x%x>",
88 c->header.uid);
89 write_c_string ("#<color-instance ", printcharfun);
90 print_internal (c->name, printcharfun, 0);
91 write_c_string (" on ", printcharfun);
92 print_internal (c->device, printcharfun, 0);
93 if (!NILP (c->device)) /* Vthe_null_color_instance */
94 MAYBE_DEVMETH (XDEVICE (c->device), print_color_instance,
95 (c, printcharfun, escapeflag));
96 sprintf (buf, " 0x%x>", c->header.uid);
97 write_c_string (buf, printcharfun);
98 }
99
100 static void
101 finalize_color_instance (void *header, int for_disksave)
102 {
103 struct Lisp_Color_Instance *c = (struct Lisp_Color_Instance *) header;
104
105 if (!NILP (c->device))
106 {
107 if (for_disksave) finalose (c);
108 MAYBE_DEVMETH (XDEVICE (c->device), finalize_color_instance, (c));
109 }
110 }
111
112 static int
113 color_instance_equal (Lisp_Object o1, Lisp_Object o2, int depth)
114 {
115 struct Lisp_Color_Instance *c1 = XCOLOR_INSTANCE (o1);
116 struct Lisp_Color_Instance *c2 = XCOLOR_INSTANCE (o2);
117 struct device *d1 = DEVICEP (c1->device) ? XDEVICE (c1->device) : 0;
118 struct device *d2 = DEVICEP (c2->device) ? XDEVICE (c2->device) : 0;
119
120 if (d1 != d2)
121 return 0;
122 if (!d1 || !HAS_DEVMETH_P (d1, color_instance_equal))
123 return EQ (o1, o2);
124 return DEVMETH (d1, color_instance_equal, (c1, c2, depth));
125 }
126
127 static unsigned long
128 color_instance_hash (Lisp_Object obj, int depth)
129 {
130 struct Lisp_Color_Instance *c = XCOLOR_INSTANCE (obj);
131 struct device *d = DEVICEP (c->device) ? XDEVICE (c->device) : 0;
132
133 return HASH2 ((unsigned long) d,
134 !d ? LISP_HASH (obj)
135 : DEVMETH_OR_GIVEN (d, color_instance_hash, (c, depth),
136 LISP_HASH (obj)));
137 }
138
139 DEFUN ("make-color-instance", Fmake_color_instance, Smake_color_instance,
140 1, 3, 0 /*
141 Creates a new `color-instance' object of the specified color.
142 DEVICE specifies the device this object applies to and defaults to the
143 selected device. An error is signalled if the color is unknown or cannot
144 be allocated; however, if NOERROR is non-nil, nil is simply returned in
145 this case. (And if NOERROR is other than t, a warning may be issued.)
146
147 The returned object is a normal, first-class lisp object. The way you
148 `deallocate' the color is the way you deallocate any other lisp object:
149 you drop all pointers to it and allow it to be garbage collected. When
150 these objects are GCed, the underlying window-system data (e.g. X object)
151 is deallocated as well.
152 */ )
153 (name, device, no_error)
154 Lisp_Object name, device, no_error;
155 {
156 struct Lisp_Color_Instance *c;
157 Lisp_Object val;
158 int retval = 0;
159
160 CHECK_STRING (name);
161 XSETDEVICE (device, decode_device (device));
162
163 c = alloc_lcrecord (sizeof (struct Lisp_Color_Instance),
164 lrecord_color_instance);
165 c->name = name;
166 c->device = device;
167
168 c->data = 0;
169
170 retval = MAYBE_INT_DEVMETH (XDEVICE (device), initialize_color_instance,
171 (c, name, device,
172 decode_error_behavior_flag (no_error)));
173
174 if (!retval)
175 return Qnil;
176
177 XSETCOLOR_INSTANCE (val, c);
178 return val;
179 }
180
181 DEFUN ("color-instance-p", Fcolor_instance_p, Scolor_instance_p, 1, 1, 0 /*
182 Return non-nil if OBJECT is a color instance.
183 */ )
184 (object)
185 Lisp_Object object;
186 {
187 return (COLOR_INSTANCEP (object) ? Qt : Qnil);
188 }
189
190 DEFUN ("color-instance-name", Fcolor_instance_name, Scolor_instance_name,
191 1, 1, 0 /*
192 Return the name used to allocate COLOR-INSTANCE.
193 */ )
194 (color_instance)
195 Lisp_Object color_instance;
196 {
197 CHECK_COLOR_INSTANCE (color_instance);
198 return (XCOLOR_INSTANCE (color_instance)->name);
199 }
200
201 DEFUN ("color-instance-rgb-components", Fcolor_instance_rgb_components,
202 Scolor_instance_rgb_components, 1, 1, 0 /*
203 Return a three element list containing the red, green, and blue
204 color components of COLOR-INSTANCE, or nil if unknown.
205 */ )
206 (color_instance)
207 Lisp_Object color_instance;
208 {
209 struct Lisp_Color_Instance *c;
210
211 CHECK_COLOR_INSTANCE (color_instance);
212 c = XCOLOR_INSTANCE (color_instance);
213
214 if (NILP (c->device))
215 return Qnil;
216 else
217 return MAYBE_LISP_DEVMETH (XDEVICE (c->device),
218 color_instance_rgb_components,
219 (c));
220 }
221
222 DEFUN ("valid-color-name-p", Fvalid_color_name_p, Svalid_color_name_p,
223 1, 2, 0 /*
224 Return true if COLOR names a valid color for the current device.
225
226 Valid color names for X are listed in the file /usr/lib/X11/rgb.txt, or
227 whatever the equivalent is on your system.
228
229 Valid color names for TTY are those which have an ISO 6429 (ANSI) sequence.
230 In addition to being a color this may be one of a number of attributes
231 such as `blink'.
232 */ )
233 (color, device)
234 Lisp_Object color, device;
235 {
236 struct device *d = decode_device (device);
237
238 CHECK_STRING (color);
239 return MAYBE_INT_DEVMETH (d, valid_color_name_p, (d, color)) ? Qt : Qnil;
240 }
241
242
243 /***************************************************************************
244 * Font-Instance Object *
245 ***************************************************************************/
246
247 Lisp_Object Qfont_instancep;
248 static Lisp_Object mark_font_instance (Lisp_Object, void (*) (Lisp_Object));
249 static void print_font_instance (Lisp_Object, Lisp_Object, int);
250 static void finalize_font_instance (void *, int);
251 static int font_instance_equal (Lisp_Object o1, Lisp_Object o2, int depth);
252 static unsigned long font_instance_hash (Lisp_Object obj, int depth);
253 DEFINE_LRECORD_IMPLEMENTATION ("font-instance", font_instance,
254 mark_font_instance, print_font_instance,
255 finalize_font_instance, font_instance_equal,
256 font_instance_hash, struct Lisp_Font_Instance);
257
258 static Lisp_Object font_instance_truename_internal (Lisp_Object xfont,
259 Error_behavior errb);
260
261 static Lisp_Object
262 mark_font_instance (Lisp_Object obj, void (*markobj) (Lisp_Object))
263 {
264 struct Lisp_Font_Instance *f = XFONT_INSTANCE (obj);
265
266 ((markobj) (f->name));
267 if (!NILP (f->device)) /* Vthe_null_font_instance */
268 MAYBE_DEVMETH (XDEVICE (f->device), mark_font_instance, (f, markobj));
269
270 return f->device;
271 }
272
273 static void
274 print_font_instance (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
275 {
276 char buf[200];
277 struct Lisp_Font_Instance *f = XFONT_INSTANCE (obj);
278 if (print_readably)
279 error ("printing unreadable object #<font-instance 0x%x>", f->header.uid);
280 write_c_string ("#<font-instance ", printcharfun);
281 print_internal (f->name, printcharfun, 1);
282 write_c_string (" on ", printcharfun);
283 print_internal (f->device, printcharfun, 0);
284 MAYBE_DEVMETH (XDEVICE (f->device), print_font_instance,
285 (f, printcharfun, escapeflag));
286 sprintf (buf, " 0x%x>", f->header.uid);
287 write_c_string (buf, printcharfun);
288 }
289
290 static void
291 finalize_font_instance (void *header, int for_disksave)
292 {
293 struct Lisp_Font_Instance *f = (struct Lisp_Font_Instance *) header;
294
295 if (!NILP (f->device))
296 {
297 if (for_disksave) finalose (f);
298 MAYBE_DEVMETH (XDEVICE (f->device), finalize_font_instance, (f));
299 }
300 }
301
302 /* Fonts are equal if they resolve to the same name.
303 Since we call `font-truename' to do this, and since font-truename is lazy,
304 this means the `equal' could cause XListFonts to be run the first time.
305 */
306 static int
307 font_instance_equal (Lisp_Object o1, Lisp_Object o2, int depth)
308 {
309 /* #### should this be moved into a device method? */
310 return (internal_equal (font_instance_truename_internal (o1, ERROR_ME_NOT),
311 font_instance_truename_internal (o2, ERROR_ME_NOT),
312 depth + 1));
313 }
314
315 static unsigned long
316 font_instance_hash (Lisp_Object obj, int depth)
317 {
318 return internal_hash (font_instance_truename_internal (obj, ERROR_ME_NOT),
319 depth + 1);
320 }
321
322 DEFUN ("make-font-instance", Fmake_font_instance, Smake_font_instance,
323 1, 3, 0 /*
324 Creates a new `font-instance' object of the specified name.
325 DEVICE specifies the device this object applies to and defaults to the
326 selected device. An error is signalled if the font is unknown or cannot
327 be allocated; however, if NOERROR is non-nil, nil is simply returned in
328 this case.
329
330 The returned object is a normal, first-class lisp object. The way you
331 `deallocate' the font is the way you deallocate any other lisp object:
332 you drop all pointers to it and allow it to be garbage collected. When
333 these objects are GCed, the underlying X data is deallocated as well.
334 */ )
335 (name, device, no_error)
336 Lisp_Object name, device, no_error;
337 {
338 struct Lisp_Font_Instance *f;
339 Lisp_Object val;
340 int retval = 0;
341 Error_behavior errb = decode_error_behavior_flag (no_error);
342
343 if (ERRB_EQ (errb, ERROR_ME))
344 CHECK_STRING (name);
345 else if (!STRINGP (name))
346 return Qnil;
347
348 XSETDEVICE (device, decode_device (device));
349
350 f = alloc_lcrecord (sizeof (struct Lisp_Font_Instance),
351 lrecord_font_instance);
352 f->name = name;
353 f->device = device;
354
355 f->data = 0;
356
357 /* Stick some default values here ... */
358 f->ascent = f->height = 1;
359 f->descent = 0;
360 f->width = 1;
361 f->proportional_p = 0;
362
363 retval = MAYBE_INT_DEVMETH (XDEVICE (device), initialize_font_instance,
364 (f, name, device, errb));
365
366 if (!retval)
367 return Qnil;
368
369 XSETFONT_INSTANCE (val, f);
370 return val;
371 }
372
373 DEFUN ("font-instance-p", Ffont_instance_p, Sfont_instance_p, 1, 1, 0 /*
374 Return non-nil if OBJECT is a font instance.
375 */ )
376 (object)
377 Lisp_Object object;
378 {
379 return (FONT_INSTANCEP (object) ? Qt : Qnil);
380 }
381
382 DEFUN ("font-instance-name", Ffont_instance_name, Sfont_instance_name, 1, 1, 0 /*
383 Return the name used to allocate FONT-INSTANCE.
384 */ )
385 (font_instance)
386 Lisp_Object font_instance;
387 {
388 CHECK_FONT_INSTANCE (font_instance);
389 return (XFONT_INSTANCE (font_instance)->name);
390 }
391
392 DEFUN ("font-instance-ascent", Ffont_instance_ascent,
393 Sfont_instance_ascent, 1, 1, 0 /*
394 Return the ascent in pixels of FONT-INSTANCE.
395 The returned value is the maximum ascent for all characters in the font,
396 where a character's ascent is the number of pixels above (and including)
397 the baseline.
398 */ )
399 (font_instance)
400 Lisp_Object font_instance;
401 {
402 CHECK_FONT_INSTANCE (font_instance);
403 return make_int (XFONT_INSTANCE (font_instance)->ascent);
404 }
405
406 DEFUN ("font-instance-descent", Ffont_instance_descent,
407 Sfont_instance_descent, 1, 1, 0 /*
408 Return the descent in pixels of FONT-INSTANCE.
409 The returned value is the maximum descent for all characters in the font,
410 where a character's descent is the number of pixels below the baseline.
411 (Many characters to do not have any descent. Typical characters with a
412 descent are lowercase p and lowercase g.)
413 */ )
414 (font_instance)
415 Lisp_Object font_instance;
416 {
417 CHECK_FONT_INSTANCE (font_instance);
418 return make_int (XFONT_INSTANCE (font_instance)->descent);
419 }
420
421 DEFUN ("font-instance-width", Ffont_instance_width,
422 Sfont_instance_width, 1, 1, 0 /*
423 Return the width in pixels of FONT-INSTANCE.
424 The returned value is the average width for all characters in the font.
425 */ )
426 (font_instance)
427 Lisp_Object font_instance;
428 {
429 CHECK_FONT_INSTANCE (font_instance);
430 return make_int (XFONT_INSTANCE (font_instance)->width);
431 }
432
433 DEFUN ("font-instance-proportional-p", Ffont_instance_proportional_p,
434 Sfont_instance_proportional_p, 1, 1, 0 /*
435 Return whether FONT-INSTANCE is proportional.
436 This means that different characters in the font have different widths.
437 */ )
438 (font_instance)
439 Lisp_Object font_instance;
440 {
441 CHECK_FONT_INSTANCE (font_instance);
442 return (XFONT_INSTANCE (font_instance)->proportional_p ? Qt : Qnil);
443 }
444
445 static Lisp_Object
446 font_instance_truename_internal (Lisp_Object font_instance,
447 Error_behavior errb)
448 {
449 struct Lisp_Font_Instance *f = XFONT_INSTANCE (font_instance);
450 return DEVMETH_OR_GIVEN (XDEVICE (f->device), font_instance_truename,
451 (f, errb), f->name);
452 }
453
454 DEFUN ("font-instance-truename", Ffont_instance_truename,
455 Sfont_instance_truename, 1, 1, 0 /*
456 Return the canonical name of FONT-INSTANCE.
457 Font names are patterns which may match any number of fonts, of which
458 the first found is used. This returns an unambiguous name for that font
459 (but not necessarily its only unambiguous name).
460 */ )
461 (font_instance)
462 Lisp_Object font_instance;
463 {
464 CHECK_FONT_INSTANCE (font_instance);
465 return font_instance_truename_internal (font_instance, ERROR_ME);
466 }
467
468 DEFUN ("font-instance-properties", Ffont_instance_properties,
469 Sfont_instance_properties, 1, 1, 0 /*
470 Return the properties (an alist or nil) of FONT-INSTANCE.
471 */ )
472 (font_instance)
473 Lisp_Object font_instance;
474 {
475 struct Lisp_Font_Instance *f;
476
477 CHECK_FONT_INSTANCE (font_instance);
478 f = XFONT_INSTANCE (font_instance);
479
480 return MAYBE_LISP_DEVMETH (XDEVICE (f->device),
481 font_instance_properties, (f));
482 }
483
484 DEFUN ("list-fonts", Flist_fonts, Slist_fonts, 1, 2, 0 /*
485 Return a list of font names matching the given pattern.
486 DEVICE specifies which device to search for names, and defaults to the
487 currently selected device.
488 */ )
489 (pattern, device)
490 Lisp_Object pattern, device;
491 {
492 CHECK_STRING (pattern);
493 XSETDEVICE (device, decode_device (device));
494
495 return MAYBE_LISP_DEVMETH (XDEVICE (device), list_fonts, (pattern, device));
496 }
497
498
499 /****************************************************************************
500 Color Object
501 ***************************************************************************/
502 DEFINE_SPECIFIER_TYPE (color);
503 /* Qcolor defined in general.c */
504
505 static void
506 color_create (Lisp_Object obj)
507 {
508 struct Lisp_Specifier *color = XCOLOR_SPECIFIER (obj);
509
510 COLOR_SPECIFIER_FACE (color) = Qnil;
511 COLOR_SPECIFIER_FACE_PROPERTY (color) = Qnil;
512 }
513
514 static void
515 color_mark (Lisp_Object obj, void (*markobj) (Lisp_Object))
516 {
517 struct Lisp_Specifier *color = XCOLOR_SPECIFIER (obj);
518
519 ((markobj) (COLOR_SPECIFIER_FACE (color)));
520 ((markobj) (COLOR_SPECIFIER_FACE_PROPERTY (color)));
521 }
522
523 /* No equal or hash methods; ignore the face the color is based off
524 of for `equal' */
525
526 static Lisp_Object
527 color_instantiate (Lisp_Object specifier, Lisp_Object matchspec,
528 Lisp_Object domain, Lisp_Object instantiator,
529 Lisp_Object depth)
530 {
531 /* When called, we're inside of call_with_suspended_errors(),
532 so we can freely error. */
533 Lisp_Object device = DFW_DEVICE (domain);
534 struct device *d = XDEVICE (device);
535 Lisp_Object instance;
536
537 if (COLOR_INSTANCEP (instantiator))
538 {
539 /* If we are on the same device then we're done. Otherwise change
540 the instantiator to the name used to generate the pixel and let the
541 STRINGP case deal with it. */
542 if (NILP (device) /* Vthe_null_color_instance */
543 || EQ (device, XCOLOR_INSTANCE (instantiator)->device))
544 return instantiator;
545 else
546 instantiator = Fcolor_instance_name (instantiator);
547 }
548
549 if (STRINGP (instantiator))
550 {
551 /* First, look to see if we can retrieve a cached value. */
552 instance = Fgethash (instantiator, d->color_instance_cache, Qunbound);
553 /* Otherwise, make a new one. */
554 if (UNBOUNDP (instance))
555 {
556 /* make sure we cache the failures, too. */
557 instance = Fmake_color_instance (instantiator, device, Qt);
558 Fputhash (instantiator, instance, d->color_instance_cache);
559 }
560
561 return (NILP (instance) ? Qunbound : instance);
562 }
563 else if (VECTORP (instantiator))
564 {
565 switch (XVECTOR (instantiator)->size)
566 {
567 case 0:
568 if (DEVICE_TTY_P (d))
569 return Vthe_null_color_instance;
570 else
571 signal_simple_error ("Color instantiator [] only valid on TTY's",
572 device);
573
574 case 1:
575 if (NILP (COLOR_SPECIFIER_FACE (XCOLOR_SPECIFIER (specifier))))
576 signal_simple_error ("Color specifier not attached to a face",
577 instantiator);
578 return (FACE_PROPERTY_INSTANCE_1
579 (Fget_face (vector_data (XVECTOR (instantiator))[0]),
580 COLOR_SPECIFIER_FACE_PROPERTY
581 (XCOLOR_SPECIFIER (specifier)), domain,
582 ERROR_ME, 0, depth));
583
584 case 2:
585 return (FACE_PROPERTY_INSTANCE_1
586 (Fget_face (vector_data (XVECTOR (instantiator))[0]),
587 vector_data (XVECTOR (instantiator))[1], domain,
588 ERROR_ME, 0, depth));
589
590 default:
591 abort ();
592 }
593 }
594 else if (NILP (instantiator))
595 {
596 if (DEVICE_TTY_P (d))
597 return Vthe_null_color_instance;
598 else
599 signal_simple_error ("Color instantiator [] only valid on TTY's",
600 device);
601 }
602 else
603 abort (); /* The spec validation routines are screwed up. */
604
605 return Qunbound;
606 }
607
608 static void
609 color_validate (Lisp_Object instantiator)
610 {
611 if (COLOR_INSTANCEP (instantiator) || STRINGP (instantiator))
612 return;
613 if (VECTORP (instantiator))
614 {
615 if (XVECTOR (instantiator)->size > 2)
616 signal_simple_error ("Inheritance vector must be of size 0 - 2",
617 instantiator);
618 else if (XVECTOR (instantiator)->size > 0)
619 {
620 Lisp_Object face = vector_data (XVECTOR (instantiator))[0];
621
622 Fget_face (face);
623 if (XVECTOR (instantiator)->size == 2)
624 {
625 Lisp_Object field = vector_data (XVECTOR (instantiator))[1];
626 if (!EQ (field, Qforeground) && !EQ (field, Qbackground))
627 signal_simple_error
628 ("Inheritance field must be `foreground' or `background'",
629 field);
630 }
631 }
632 }
633 else
634 signal_simple_error ("Invalid color instantiator", instantiator);
635 }
636
637 static void
638 color_after_change (Lisp_Object specifier, Lisp_Object locale)
639 {
640 Lisp_Object face = COLOR_SPECIFIER_FACE (XCOLOR_SPECIFIER (specifier));
641 Lisp_Object property =
642 COLOR_SPECIFIER_FACE_PROPERTY (XCOLOR_SPECIFIER (specifier));
643 if (!NILP (face))
644 face_property_was_changed (face, property, locale);
645 }
646
647 void
648 set_color_attached_to (Lisp_Object obj, Lisp_Object face, Lisp_Object property)
649 {
650 struct Lisp_Specifier *color = XCOLOR_SPECIFIER (obj);
651
652 COLOR_SPECIFIER_FACE (color) = face;
653 COLOR_SPECIFIER_FACE_PROPERTY (color) = property;
654 }
655
656 DEFUN ("color-specifier-p", Fcolor_specifier_p, Scolor_specifier_p, 1, 1, 0 /*
657 Return non-nil if OBJECT is a color specifier.
658
659 Valid instantiators for color specifiers are:
660
661 -- a string naming a color (e.g. under X this might be \"lightseagreen2\"
662 or \"#F534B2\")
663 -- a color instance (use that instance directly if the device matches,
664 or use the string that generated it)
665 -- a vector of no elements (only on TTY's; this means to set no color
666 at all, thus using the \"natural\" color of the terminal's text)
667 -- a vector of one or two elements: a face to inherit from, and
668 optionally a symbol naming which property of that face to inherit,
669 either `foreground' or `background' (if omitted, defaults to the same
670 property that this color specifier is used for; if this specifier is
671 not part of a face, the instantiator would not be valid)
672 */ )
673 (object)
674 Lisp_Object object;
675 {
676 return (COLOR_SPECIFIERP (object) ? Qt : Qnil);
677 }
678
679
680 /****************************************************************************
681 Font Object
682 ***************************************************************************/
683 DEFINE_SPECIFIER_TYPE (font);
684 /* Qfont defined in general.c */
685
686 static void
687 font_create (Lisp_Object obj)
688 {
689 struct Lisp_Specifier *font = XFONT_SPECIFIER (obj);
690
691 FONT_SPECIFIER_FACE (font) = Qnil;
692 FONT_SPECIFIER_FACE_PROPERTY (font) = Qnil;
693 }
694
695 static void
696 font_mark (Lisp_Object obj, void (*markobj) (Lisp_Object))
697 {
698 struct Lisp_Specifier *font = XFONT_SPECIFIER (obj);
699
700 ((markobj) (FONT_SPECIFIER_FACE (font)));
701 ((markobj) (FONT_SPECIFIER_FACE_PROPERTY (font)));
702 }
703
704 /* No equal or hash methods; ignore the face the font is based off
705 of for `equal' */
706
707 int
708 font_spec_matches_charset (struct device *d, Lisp_Object charset,
709 CONST Bufbyte *nonreloc, Lisp_Object reloc,
710 Bytecount offset, Bytecount length)
711 {
712 return DEVMETH_OR_GIVEN (d, font_spec_matches_charset,
713 (d, charset, nonreloc, reloc, offset, length),
714 1);
715 }
716
717 static Lisp_Object
718 font_instantiate (Lisp_Object specifier, Lisp_Object matchspec,
719 Lisp_Object domain, Lisp_Object instantiator,
720 Lisp_Object depth)
721 {
722 /* When called, we're inside of call_with_suspended_errors(),
723 so we can freely error. */
724 Lisp_Object device = DFW_DEVICE (domain);
725 struct device *d = XDEVICE (device);
726 Lisp_Object instance;
727
728 if (FONT_INSTANCEP (instantiator))
729 {
730 if (NILP (device) /* Vthe_null_color_instance */
731 || EQ (device, XFONT_INSTANCE (instantiator)->device))
732 {
733 return instantiator;
734 }
735 instantiator = Ffont_instance_name (instantiator);
736 }
737 else if (STRINGP (instantiator))
738 {
739 /* First, look to see if we can retrieve a cached value. */
740 instance = Fgethash (instantiator, d->font_instance_cache, Qunbound);
741 /* Otherwise, make a new one. */
742 if (UNBOUNDP (instance))
743 {
744 /* make sure we cache the failures, too. */
745 instance = Fmake_font_instance (instantiator, device, Qt);
746 Fputhash (instantiator, instance, d->font_instance_cache);
747 }
748
749 return (NILP (instance) ? Qunbound : instance);
750 }
751 else if (VECTORP (instantiator))
752 {
753 assert (XVECTOR (instantiator)->size == 1);
754 return (face_property_matching_instance
755 (Fget_face (vector_data (XVECTOR (instantiator))[0]), Qfont,
756 matchspec, domain, ERROR_ME, 0, depth));
757 }
758 else if (NILP (instantiator))
759 return Qunbound;
760 else
761 abort (); /* Eh? */
762
763 return Qunbound;
764 }
765
766 static void
767 font_validate (Lisp_Object instantiator)
768 {
769 if (FONT_INSTANCEP (instantiator) || STRINGP (instantiator))
770 return;
771 if (VECTORP (instantiator))
772 {
773 if (vector_length (XVECTOR (instantiator)) != 1)
774 {
775 signal_simple_error
776 ("Vector length must be one for font inheritance", instantiator);
777 }
778 Fget_face (vector_data (XVECTOR (instantiator))[0]);
779 }
780 else
781 signal_simple_error ("Must be string, vector, or font-instance",
782 instantiator);
783 }
784
785 static void
786 font_after_change (Lisp_Object specifier, Lisp_Object locale)
787 {
788 Lisp_Object face = FONT_SPECIFIER_FACE (XFONT_SPECIFIER (specifier));
789 Lisp_Object property =
790 FONT_SPECIFIER_FACE_PROPERTY (XFONT_SPECIFIER (specifier));
791 if (!NILP (face))
792 face_property_was_changed (face, property, locale);
793 }
794
795 void
796 set_font_attached_to (Lisp_Object obj, Lisp_Object face, Lisp_Object property)
797 {
798 struct Lisp_Specifier *font = XFONT_SPECIFIER (obj);
799
800 FONT_SPECIFIER_FACE (font) = face;
801 FONT_SPECIFIER_FACE_PROPERTY (font) = property;
802 }
803
804 DEFUN ("font-specifier-p", Ffont_specifier_p, Sfont_specifier_p, 1, 1, 0 /*
805 Return non-nil if OBJECT is a font specifier.
806
807 Valid instantiators for font specifiers are:
808
809 -- a string naming a font (e.g. under X this might be
810 \"-*-courier-medium-r-*-*-*-140-*-*-*-*-iso8859-*\" for a 14-point
811 upright medium-weight Courier font)
812 -- a font instance (use that instance directly if the device matches,
813 or use the string that generated it)
814 -- a vector of no elements (only on TTY's; this means to set no font
815 at all, thus using the \"natural\" font of the terminal's text)
816 -- a vector of one element (a face to inherit from)
817 */ )
818 (object)
819 Lisp_Object object;
820 {
821 return (FONT_SPECIFIERP (object) ? Qt : Qnil);
822 }
823
824
825 /*****************************************************************************
826 Face Boolean Object
827 ****************************************************************************/
828 DEFINE_SPECIFIER_TYPE (face_boolean);
829 Lisp_Object Qface_boolean;
830
831 static void
832 face_boolean_create (Lisp_Object obj)
833 {
834 struct Lisp_Specifier *face_boolean = XFACE_BOOLEAN_SPECIFIER (obj);
835
836 FACE_BOOLEAN_SPECIFIER_FACE (face_boolean) = Qnil;
837 FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY (face_boolean) = Qnil;
838 }
839
840 static void
841 face_boolean_mark (Lisp_Object obj, void (*markobj) (Lisp_Object))
842 {
843 struct Lisp_Specifier *face_boolean = XFACE_BOOLEAN_SPECIFIER (obj);
844
845 ((markobj) (FACE_BOOLEAN_SPECIFIER_FACE (face_boolean)));
846 ((markobj) (FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY (face_boolean)));
847 }
848
849 /* No equal or hash methods; ignore the face the face-boolean is based off
850 of for `equal' */
851
852 static Lisp_Object
853 face_boolean_instantiate (Lisp_Object specifier, Lisp_Object matchspec,
854 Lisp_Object domain, Lisp_Object instantiator,
855 Lisp_Object depth)
856 {
857 /* When called, we're inside of call_with_suspended_errors(),
858 so we can freely error. */
859 if (NILP (instantiator) || EQ (instantiator, Qt))
860 return instantiator;
861 else if (VECTORP (instantiator))
862 {
863 Lisp_Object retval;
864 Lisp_Object prop;
865
866 assert (XVECTOR (instantiator)->size >= 1 &&
867 XVECTOR (instantiator)->size <= 3);
868 if (XVECTOR (instantiator)->size > 1)
869 prop = vector_data (XVECTOR (instantiator))[1];
870 else
871 {
872 if (NILP (FACE_BOOLEAN_SPECIFIER_FACE
873 (XFACE_BOOLEAN_SPECIFIER (specifier))))
874 signal_simple_error
875 ("Face-boolean specifier not attached to a face", instantiator);
876 prop = FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY
877 (XFACE_BOOLEAN_SPECIFIER (specifier));
878 }
879
880 retval = (FACE_PROPERTY_INSTANCE_1
881 (Fget_face (vector_data (XVECTOR (instantiator))[0]),
882 prop, domain, ERROR_ME, 0, depth));
883
884 if (XVECTOR (instantiator)->size == 3 &&
885 !NILP (vector_data (XVECTOR (instantiator))[2]))
886 retval = (NILP (retval) ? Qt : Qnil);
887
888 return retval;
889 }
890 else
891 abort (); /* Eh? */
892
893 return Qunbound;
894 }
895
896 static void
897 face_boolean_validate (Lisp_Object instantiator)
898 {
899 if (NILP (instantiator) || EQ (instantiator, Qt))
900 return;
901 else if (VECTORP (instantiator) &&
902 (XVECTOR (instantiator)->size >= 1 &&
903 XVECTOR (instantiator)->size <= 3))
904 {
905 Lisp_Object face = vector_data (XVECTOR (instantiator))[0];
906
907 Fget_face (face);
908
909 if (XVECTOR (instantiator)->size > 1)
910 {
911 Lisp_Object field = vector_data (XVECTOR (instantiator))[1];
912 if (!EQ (field, Qunderline)
913 && !EQ (field, Qstrikethru)
914 && !EQ (field, Qhighlight)
915 && !EQ (field, Qdim)
916 && !EQ (field, Qblinking)
917 && !EQ (field, Qreverse))
918 signal_simple_error ("Invalid face-boolean inheritance field",
919 field);
920 }
921 }
922 else if (VECTORP (instantiator))
923 signal_simple_error ("Wrong length for face-boolean inheritance spec",
924 instantiator);
925 else
926 signal_simple_error ("Face-boolean instantiator must be nil, t, or vector",
927 instantiator);
928 }
929
930 static void
931 face_boolean_after_change (Lisp_Object specifier, Lisp_Object locale)
932 {
933 Lisp_Object face =
934 FACE_BOOLEAN_SPECIFIER_FACE (XFACE_BOOLEAN_SPECIFIER (specifier));
935 Lisp_Object property =
936 FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY (XFACE_BOOLEAN_SPECIFIER (specifier));
937 if (!NILP (face))
938 face_property_was_changed (face, property, locale);
939 }
940
941 void
942 set_face_boolean_attached_to (Lisp_Object obj, Lisp_Object face,
943 Lisp_Object property)
944 {
945 struct Lisp_Specifier *face_boolean = XFACE_BOOLEAN_SPECIFIER (obj);
946
947 FACE_BOOLEAN_SPECIFIER_FACE (face_boolean) = face;
948 FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY (face_boolean) = property;
949 }
950
951 DEFUN ("face-boolean-specifier-p", Fface_boolean_specifier_p,
952 Sface_boolean_specifier_p, 1, 1, 0 /*
953 Return non-nil if OBJECT is a face-boolean specifier.
954
955 Valid instantiators for face-boolean specifiers are
956
957 -- t or nil
958 -- a vector of two or three elements: a face to inherit from,
959 optionally a symbol naming the property of that face to inherit from
960 (if omitted, defaults to the same property that this face-boolean
961 specifier is used for; if this specifier is not part of a face,
962 the instantiator would not be valid), and optionally a value which,
963 if non-nil, means to invert the sense of the inherited property.
964 */ )
965 (object)
966 Lisp_Object object;
967 {
968 return (FACE_BOOLEAN_SPECIFIERP (object) ? Qt : Qnil);
969 }
970
971
972 /************************************************************************/
973 /* initialization */
974 /************************************************************************/
975
976 void
977 syms_of_objects (void)
978 {
979 defsubr (&Scolor_specifier_p);
980 defsubr (&Sfont_specifier_p);
981 defsubr (&Sface_boolean_specifier_p);
982
983 defsymbol (&Qcolor_instancep, "color-instance-p");
984 defsubr (&Smake_color_instance);
985 defsubr (&Scolor_instance_p);
986 defsubr (&Scolor_instance_name);
987 defsubr (&Scolor_instance_rgb_components);
988 defsubr (&Svalid_color_name_p);
989
990 defsymbol (&Qfont_instancep, "font-instance-p");
991 defsubr (&Smake_font_instance);
992 defsubr (&Sfont_instance_p);
993 defsubr (&Sfont_instance_name);
994 defsubr (&Sfont_instance_ascent);
995 defsubr (&Sfont_instance_descent);
996 defsubr (&Sfont_instance_width);
997 defsubr (&Sfont_instance_proportional_p);
998 defsubr (&Sfont_instance_truename);
999 defsubr (&Sfont_instance_properties);
1000 defsubr (&Slist_fonts);
1001
1002 /* Qcolor, Qfont defined in general.c */
1003 defsymbol (&Qface_boolean, "face-boolean");
1004 }
1005
1006 void
1007 specifier_type_create_objects (void)
1008 {
1009 INITIALIZE_SPECIFIER_TYPE_WITH_DATA (color, "color", "color-specifier-p");
1010 INITIALIZE_SPECIFIER_TYPE_WITH_DATA (font, "font", "font-specifier-p");
1011 INITIALIZE_SPECIFIER_TYPE_WITH_DATA (face_boolean, "face-boolean",
1012 "face-boolean-specifier-p");
1013
1014 SPECIFIER_HAS_METHOD (color, instantiate);
1015 SPECIFIER_HAS_METHOD (font, instantiate);
1016 SPECIFIER_HAS_METHOD (face_boolean, instantiate);
1017
1018 SPECIFIER_HAS_METHOD (color, validate);
1019 SPECIFIER_HAS_METHOD (font, validate);
1020 SPECIFIER_HAS_METHOD (face_boolean, validate);
1021
1022 SPECIFIER_HAS_METHOD (color, create);
1023 SPECIFIER_HAS_METHOD (font, create);
1024 SPECIFIER_HAS_METHOD (face_boolean, create);
1025
1026 SPECIFIER_HAS_METHOD (color, mark);
1027 SPECIFIER_HAS_METHOD (font, mark);
1028 SPECIFIER_HAS_METHOD (face_boolean, mark);
1029
1030 SPECIFIER_HAS_METHOD (color, after_change);
1031 SPECIFIER_HAS_METHOD (font, after_change);
1032 SPECIFIER_HAS_METHOD (face_boolean, after_change);
1033 }
1034
1035 void
1036 vars_of_objects (void)
1037 {
1038 staticpro (&Vthe_null_color_instance);
1039 {
1040 struct Lisp_Color_Instance *c;
1041
1042 c = alloc_lcrecord (sizeof (struct Lisp_Color_Instance),
1043 lrecord_color_instance);
1044 c->name = Qnil;
1045 c->device = Qnil;
1046 c->data = 0;
1047
1048 XSETCOLOR_INSTANCE (Vthe_null_color_instance, c);
1049 }
1050
1051 staticpro (&Vthe_null_font_instance);
1052 {
1053 struct Lisp_Font_Instance *f;
1054
1055 f = alloc_lcrecord (sizeof (struct Lisp_Font_Instance),
1056 lrecord_font_instance);
1057 f->name = Qnil;
1058 f->device = Qnil;
1059 f->data = 0;
1060
1061 f->ascent = f->height = 0;
1062 f->descent = 0;
1063 f->width = 0;
1064 f->proportional_p = 0;
1065
1066 XSETFONT_INSTANCE (Vthe_null_font_instance, f);
1067 }
1068 }