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

Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children 9ee227acff29
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 /* Generic glyph/image implementation + display tables
2 Copyright (C) 1994, 1995 Board of Trustees, University of Illinois.
3 Copyright (C) 1995 Tinker Systems
4 Copyright (C) 1995, 1996 Ben Wing
5 Copyright (C) 1995 Sun Microsystems
6
7 This file is part of XEmacs.
8
9 XEmacs is free software; you can redistribute it and/or modify it
10 under the terms of the GNU General Public License as published by the
11 Free Software Foundation; either version 2, or (at your option) any
12 later version.
13
14 XEmacs is distributed in the hope that it will be useful, but WITHOUT
15 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 for more details.
18
19 You should have received a copy of the GNU General Public License
20 along with XEmacs; see the file COPYING. If not, write to
21 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22 Boston, MA 02111-1307, USA. */
23
24 /* Synched up with: Not in FSF. */
25
26 /* Written by Ben Wing and Chuck Thompson */
27
28 #include <config.h>
29 #include "lisp.h"
30
31 #include "buffer.h"
32 #include "device.h"
33 #include "elhash.h"
34 #include "faces.h"
35 #include "frame.h"
36 #include "glyphs.h"
37 #include "objects.h"
38 #include "redisplay.h"
39 #include "window.h"
40
41 Lisp_Object Qglyphp, Qcontrib_p, Qbaseline;
42
43 Lisp_Object Qbuffer_glyph_p, Qpointer_glyph_p, Qicon_glyph_p;
44
45 Lisp_Object Qnothing_image_instance_p, Qtext_image_instance_p;
46 Lisp_Object Qmono_pixmap_image_instance_p;
47 Lisp_Object Qcolor_pixmap_image_instance_p;
48 Lisp_Object Qpointer_image_instance_p;
49 Lisp_Object Qsubwindow_image_instance_p;
50
51 Lisp_Object Qconst_glyph_variable;
52
53 /* Qtext, Qpointer defined in general.c */
54 Lisp_Object Qmono_pixmap, Qcolor_pixmap, Qsubwindow;
55
56 Lisp_Object Vcurrent_display_table;
57
58 Lisp_Object Vtruncation_glyph, Vcontinuation_glyph, Voctal_escape_glyph;
59 Lisp_Object Vcontrol_arrow_glyph, Vinvisible_text_glyph, Vhscroll_glyph;
60 Lisp_Object Vxemacs_logo;
61
62 Lisp_Object Vthe_nothing_vector;
63
64 Lisp_Object Q_file, Q_data, Q_face;
65
66 Lisp_Object Qicon;
67
68 /* Qnothing, Qstring, Qinherit in general.c */
69 DEFINE_IMAGE_INSTANTIATOR_FORMAT (nothing);
70 DEFINE_IMAGE_INSTANTIATOR_FORMAT (inherit);
71 DEFINE_IMAGE_INSTANTIATOR_FORMAT (string);
72 DEFINE_IMAGE_INSTANTIATOR_FORMAT (formatted_string);
73 Lisp_Object Qformatted_string;
74
75 MAC_DEFINE (struct image_instantiator_methods *, MTiiformat_meth_or_given)
76
77 struct image_instantiator_format_entry
78 {
79 Lisp_Object symbol;
80 struct image_instantiator_methods *meths;
81 };
82
83 typedef struct image_instantiator_format_entry_dynarr_type
84 {
85 Dynarr_declare (struct image_instantiator_format_entry);
86 } image_instantiator_format_entry_dynarr;
87
88 image_instantiator_format_entry_dynarr *
89 the_image_instantiator_format_entry_dynarr;
90
91 Lisp_Object Vimage_instantiator_format_list;
92
93 Lisp_Object Vimage_instance_type_list;
94
95 Lisp_Object Vglyph_type_list;
96
97 static Lisp_Object allocate_image_instance (Lisp_Object device);
98 static void image_validate (Lisp_Object instantiator);
99 static void glyph_property_was_changed (Lisp_Object glyph,
100 Lisp_Object property,
101 Lisp_Object locale);
102
103
104 /****************************************************************************
105 * Image Instantiators *
106 ****************************************************************************/
107
108 static struct image_instantiator_methods *
109 decode_image_instantiator_format (Lisp_Object format, Error_behavior errb)
110 {
111 int i;
112
113 if (!SYMBOLP (format))
114 {
115 if (ERRB_EQ (errb, ERROR_ME))
116 CHECK_SYMBOL (format);
117 return 0;
118 }
119
120 for (i = 0; i < Dynarr_length (the_image_instantiator_format_entry_dynarr);
121 i++)
122 {
123 if (EQ (format,
124 Dynarr_at (the_image_instantiator_format_entry_dynarr, i).
125 symbol))
126 return Dynarr_at (the_image_instantiator_format_entry_dynarr, i).meths;
127 }
128
129 maybe_signal_simple_error ("Invalid image-instantiator format", format,
130 Qimage, errb);
131
132 return 0;
133 }
134
135 static int
136 valid_image_instantiator_format_p (Lisp_Object format)
137 {
138 if (decode_image_instantiator_format (format, ERROR_ME_NOT))
139 return 1;
140 return 0;
141 }
142
143 DEFUN ("valid-image-instantiator-format-p", Fvalid_image_instantiator_format_p,
144 Svalid_image_instantiator_format_p, 1, 1, 0 /*
145 Given an IMAGE-INSTANTIATOR-FORMAT, return non-nil if it is valid.
146 Valid formats are some subset of 'nothing, 'string, 'formatted-string, 'xpm,
147 'xbm, 'xface, 'gif, 'jpeg, 'png, 'tiff, 'cursor-font, 'font, 'autodetect,
148 and 'subwindow, depending on how XEmacs was compiled.
149 */ )
150 (image_instantiator_format)
151 Lisp_Object image_instantiator_format;
152 {
153 if (valid_image_instantiator_format_p (image_instantiator_format))
154 return Qt;
155 else
156 return Qnil;
157 }
158
159 DEFUN ("image-instantiator-format-list", Fimage_instantiator_format_list,
160 Simage_instantiator_format_list,
161 0, 0, 0 /*
162 Return a list of valid image-instantiator formats.
163 */ )
164 ()
165 {
166 return Fcopy_sequence (Vimage_instantiator_format_list);
167 }
168
169 void
170 add_entry_to_image_instantiator_format_list (Lisp_Object symbol,
171 struct
172 image_instantiator_methods *meths)
173 {
174 struct image_instantiator_format_entry entry;
175
176 entry.symbol = symbol;
177 entry.meths = meths;
178 Dynarr_add (the_image_instantiator_format_entry_dynarr, entry);
179 Vimage_instantiator_format_list =
180 Fcons (symbol, Vimage_instantiator_format_list);
181 }
182
183 static Lisp_Object *
184 get_image_conversion_list (Lisp_Object console_type)
185 {
186 return &decode_console_type (console_type, ERROR_ME)->image_conversion_list;
187 }
188
189 DEFUN ("set-console-type-image-conversion-list",
190 Fset_console_type_image_conversion_list,
191 Sset_console_type_image_conversion_list, 2, 2, 0 /*
192 Set the image-conversion-list for consoles of the given TYPE.
193 The image-conversion-list specifies how image instantiators that
194 are strings should be interpreted. Each element of the list should be
195 a list of two elements (a regular expression string and a vector) or
196 a list of three elements (the preceding two plus an integer index into
197 the vector). The string is converted to the vector associated with the
198 first matching regular expression. If a vector index is specified, the
199 string itself is substituted into that position in the vector.
200
201 Note: The conversion above is applied when the image instantiator is
202 added to an image specifier, not when the specifier is actually
203 instantiated. Therefore, changing the image-conversion-list only affects
204 newly-added instantiators. Existing instantiators in glyphs and image
205 specifiers will not be affected.
206 */ )
207 (console_type, list)
208 Lisp_Object console_type, list;
209 {
210 Lisp_Object tail;
211 Lisp_Object *imlist = get_image_conversion_list (console_type);
212
213 /* Check the list to make sure that it only has valid entries. */
214
215 EXTERNAL_LIST_LOOP (tail, list)
216 {
217 Lisp_Object mapping = XCAR (tail);
218
219 /* Mapping form should be (STRING VECTOR) or (STRING VECTOR INTEGER) */
220 if (!CONSP (mapping) ||
221 !CONSP (XCDR (mapping)) ||
222 (!NILP (XCDR (XCDR (mapping))) &&
223 (!CONSP (XCDR (XCDR (mapping))) ||
224 !NILP (XCDR (XCDR (XCDR (mapping)))))))
225 signal_simple_error ("Invalid mapping form", mapping);
226 else
227 {
228 Lisp_Object exp = XCAR (mapping);
229 Lisp_Object typevec = XCAR (XCDR (mapping));
230 Lisp_Object pos = Qnil;
231 Lisp_Object newvec;
232 struct gcpro gcpro1;
233
234 CHECK_STRING (exp);
235 CHECK_VECTOR (typevec);
236 if (!NILP (XCDR (XCDR (mapping))))
237 {
238 pos = XCAR (XCDR (XCDR (mapping)));
239 CHECK_INT (pos);
240 if (XINT (pos) < 0 ||
241 XINT (pos) >= vector_length (XVECTOR (typevec)))
242 args_out_of_range_3
243 (pos, Qzero, make_int
244 (vector_length (XVECTOR (typevec)) - 1));
245 }
246
247 newvec = Fcopy_sequence (typevec);
248 if (INTP (pos))
249 vector_data (XVECTOR (newvec))[XINT (pos)] = exp;
250 GCPRO1 (newvec);
251 image_validate (newvec);
252 UNGCPRO;
253 }
254 }
255
256 *imlist = Fcopy_tree (list, Qt);
257 return list;
258 }
259
260 DEFUN ("console-type-image-conversion-list",
261 Fconsole_type_image_conversion_list,
262 Sconsole_type_image_conversion_list, 1, 1, 0 /*
263 Return the image-conversion-list for devices of the given TYPE.
264 The image-conversion-list specifies how to interpret image string
265 instantiators for the specified console type. See
266 `set-console-type-image-conversion-list' for a description of its syntax.
267 */ )
268 (console_type)
269 Lisp_Object console_type;
270 {
271 return Fcopy_tree (*get_image_conversion_list (console_type), Qt);
272 }
273
274 /* Process an string instantiator according to the image-conversion-list for
275 CONSOLE_TYPE. Returns a vector. */
276
277 static Lisp_Object
278 process_image_string_instantiator (Lisp_Object data,
279 Lisp_Object console_type,
280 int dest_mask)
281 {
282 Lisp_Object tail;
283
284 LIST_LOOP (tail, *get_image_conversion_list (console_type))
285 {
286 Lisp_Object mapping = XCAR (tail);
287 Lisp_Object exp = XCAR (mapping);
288 Lisp_Object typevec = XCAR (XCDR (mapping));
289
290 /* if the result is of a type that can't be instantiated
291 (e.g. a string when we're dealing with a pointer glyph),
292 skip it. */
293 if (!(dest_mask &
294 IIFORMAT_METH (decode_image_instantiator_format
295 (vector_data (XVECTOR (typevec))[0], ERROR_ME),
296 possible_dest_types, ())))
297 continue;
298 if (fast_string_match (exp, 0, data, 0, -1, 0, ERROR_ME, 0) >= 0)
299 {
300 if (!NILP (XCDR (XCDR (mapping))))
301 {
302 int pos = XINT (XCAR (XCDR (XCDR (mapping))));
303 Lisp_Object newvec = Fcopy_sequence (typevec);
304 vector_data (XVECTOR (newvec))[pos] = data;
305 return newvec;
306 }
307 else
308 return typevec;
309 }
310 }
311
312 /* Oh well. */
313 signal_simple_error ("Unable to interpret glyph instantiator",
314 data);
315
316 return Qnil;
317 }
318
319 Lisp_Object
320 find_keyword_in_vector_or_given (Lisp_Object vector, Lisp_Object keyword,
321 Lisp_Object defalt)
322 {
323 Lisp_Object *elt;
324 int instantiator_len;
325
326 elt = vector_data (XVECTOR (vector));
327 instantiator_len = vector_length (XVECTOR (vector));
328
329 elt++;
330 instantiator_len--;
331
332 while (instantiator_len > 0)
333 {
334 if (EQ (elt[0], keyword))
335 return elt[1];
336 elt += 2;
337 instantiator_len -= 2;
338 }
339
340 return defalt;
341 }
342
343 Lisp_Object
344 find_keyword_in_vector (Lisp_Object vector, Lisp_Object keyword)
345 {
346 return find_keyword_in_vector_or_given (vector, keyword, Qnil);
347 }
348
349 void
350 check_valid_string (Lisp_Object data)
351 {
352 CHECK_STRING (data);
353 }
354
355 static void
356 check_valid_face (Lisp_Object data)
357 {
358 Fget_face (data);
359 }
360
361 void
362 check_valid_int (Lisp_Object data)
363 {
364 CHECK_INT (data);
365 }
366
367 void
368 file_or_data_must_be_present (Lisp_Object instantiator)
369 {
370 if (NILP (find_keyword_in_vector (instantiator, Q_file)) &&
371 NILP (find_keyword_in_vector (instantiator, Q_data)))
372 signal_simple_error ("Must supply either :file or :data",
373 instantiator);
374 }
375
376 void
377 data_must_be_present (Lisp_Object instantiator)
378 {
379 if (NILP (find_keyword_in_vector (instantiator, Q_data)))
380 signal_simple_error ("Must supply :data", instantiator);
381 }
382
383 static void
384 face_must_be_present (Lisp_Object instantiator)
385 {
386 if (NILP (find_keyword_in_vector (instantiator, Q_face)))
387 signal_simple_error ("Must supply :face", instantiator);
388 }
389
390 /* utility function useful in retrieving data from a file. */
391
392 Lisp_Object
393 make_string_from_file (Lisp_Object file)
394 {
395 int count = specpdl_depth ();
396 Lisp_Object temp_buffer;
397 struct gcpro gcpro1;
398 Lisp_Object data;
399
400 specbind (Qinhibit_quit, Qt);
401 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
402 temp_buffer = Fget_buffer_create (build_string (" *pixmap conversion*"));
403 GCPRO1 (temp_buffer);
404 set_buffer_internal (XBUFFER (temp_buffer));
405 Ferase_buffer (Fcurrent_buffer ());
406 Finsert_file_contents_internal (file, Qnil, Qnil, Qnil, Qnil);
407 data = Fbuffer_substring (Qnil, Qnil, Fcurrent_buffer ());
408 unbind_to (count, Qnil);
409 UNGCPRO;
410 return data;
411 }
412
413 /* The following two functions are provided to make it easier for
414 the normalize methods to work with keyword-value vectors.
415 Hash tables are kind of heavyweight for this purpose.
416 (If vectors were resizable, we could avoid this problem;
417 but they're not.) An alternative approach that might be
418 more efficient but require more work is to use a type of
419 assoc-Dynarr and provide primitives for deleting elements out
420 of it. (However, you'd also have to add an unwind-protect
421 to make sure the Dynarr got freed in case of an error in
422 the normalization process.) */
423
424 Lisp_Object
425 tagged_vector_to_alist (Lisp_Object vector)
426 {
427 Lisp_Object *elt = vector_data (XVECTOR (vector));
428 int len = vector_length (XVECTOR (vector));
429 Lisp_Object result = Qnil;
430
431 assert (len & 1);
432 for (len -= 2; len >= 1; len -= 2)
433 result = Fcons (Fcons (elt[len], elt[len+1]), result);
434
435 return result;
436 }
437
438 Lisp_Object
439 alist_to_tagged_vector (Lisp_Object tag, Lisp_Object alist)
440 {
441 int len = 1 + 2 * XINT (Flength (alist));
442 Lisp_Object *elt = (Lisp_Object *) alloca (len * sizeof (Lisp_Object));
443 int i;
444 Lisp_Object rest;
445
446 i = 0;
447 elt[i++] = tag;
448 LIST_LOOP (rest, alist)
449 {
450 Lisp_Object pair = XCAR (rest);
451 elt[i] = XCAR (pair);
452 elt[i+1] = XCDR (pair);
453 i += 2;
454 }
455
456 return Fvector (len, elt);
457 }
458
459 static Lisp_Object
460 normalize_image_instantiator (Lisp_Object instantiator,
461 Lisp_Object contype,
462 Lisp_Object dest_mask)
463 {
464 if (IMAGE_INSTANCEP (instantiator))
465 return instantiator;
466
467 if (STRINGP (instantiator))
468 instantiator = process_image_string_instantiator (instantiator, contype,
469 XINT (dest_mask));
470
471 assert (VECTORP (instantiator));
472 /* We have to always store the actual pixmap data and not the
473 filename even though this is a potential memory pig. We have to
474 do this because it is quite possible that we will need to
475 instantiate a new instance of the pixmap and the file will no
476 longer exist (e.g. w3 pixmaps are almost always from temporary
477 files). */
478 instantiator = IIFORMAT_METH_OR_GIVEN
479 (decode_image_instantiator_format
480 (vector_data (XVECTOR (instantiator))[0], ERROR_ME),
481 normalize, (instantiator, contype), instantiator);
482
483 return instantiator;
484 }
485
486 static Lisp_Object
487 instantiate_image_instantiator (Lisp_Object device, Lisp_Object instantiator,
488 Lisp_Object pointer_fg, Lisp_Object pointer_bg,
489 int dest_mask)
490 {
491 Lisp_Object ii;
492 struct gcpro gcpro1;
493
494 ii = allocate_image_instance (device);
495
496 GCPRO1 (ii);
497 {
498 struct image_instantiator_methods *meths =
499 decode_image_instantiator_format
500 (vector_data (XVECTOR (instantiator))[0], ERROR_ME);
501
502 if (!HAS_IIFORMAT_METH_P (meths, instantiate))
503 signal_simple_error
504 ("Don't know how to instantiate this image instantiator?",
505 instantiator);
506 IIFORMAT_METH (meths, instantiate, (ii, instantiator, pointer_fg,
507 pointer_bg, dest_mask));
508 }
509 UNGCPRO;
510
511 return ii;
512 }
513
514
515 /****************************************************************************
516 * Image-Instance Object *
517 ****************************************************************************/
518
519 Lisp_Object Qimage_instancep;
520 static Lisp_Object mark_image_instance (Lisp_Object, void (*) (Lisp_Object));
521 static void print_image_instance (Lisp_Object, Lisp_Object, int);
522 static void finalize_image_instance (void *, int);
523 static int image_instance_equal (Lisp_Object o1, Lisp_Object o2, int depth);
524 static unsigned long image_instance_hash (Lisp_Object obj, int depth);
525 DEFINE_LRECORD_IMPLEMENTATION ("image-instance", image_instance,
526 mark_image_instance, print_image_instance,
527 finalize_image_instance, image_instance_equal,
528 image_instance_hash,
529 struct Lisp_Image_Instance);
530 static Lisp_Object
531 mark_image_instance (Lisp_Object obj, void (*markobj) (Lisp_Object))
532 {
533 struct Lisp_Image_Instance *i = XIMAGE_INSTANCE (obj);
534
535 (markobj) (i->name);
536 switch (IMAGE_INSTANCE_TYPE (i))
537 {
538 case IMAGE_TEXT:
539 (markobj) (IMAGE_INSTANCE_TEXT_STRING (i));
540 break;
541 case IMAGE_MONO_PIXMAP:
542 case IMAGE_COLOR_PIXMAP:
543 (markobj) (IMAGE_INSTANCE_PIXMAP_FILENAME (i));
544 (markobj) (IMAGE_INSTANCE_PIXMAP_MASK_FILENAME (i));
545 (markobj) (IMAGE_INSTANCE_PIXMAP_HOTSPOT_X (i));
546 (markobj) (IMAGE_INSTANCE_PIXMAP_HOTSPOT_Y (i));
547 (markobj) (IMAGE_INSTANCE_PIXMAP_FG (i));
548 (markobj) (IMAGE_INSTANCE_PIXMAP_BG (i));
549 break;
550 case IMAGE_SUBWINDOW:
551 /* #### implement me */
552 break;
553 default:
554 break;
555 }
556
557 MAYBE_DEVMETH (XDEVICE (i->device), mark_image_instance, (i, markobj));
558
559 return (i->device);
560 }
561
562 static void
563 print_image_instance (Lisp_Object obj, Lisp_Object printcharfun,
564 int escapeflag)
565 {
566 char buf[100];
567 struct Lisp_Image_Instance *ii = XIMAGE_INSTANCE (obj);
568
569 if (print_readably)
570 error ("printing unreadable object #<image-instance 0x%x>",
571 ii->header.uid);
572 write_c_string ("#<image-instance (", printcharfun);
573 print_internal (Fimage_instance_type (obj), printcharfun, 0);
574 write_c_string (") ", printcharfun);
575 if (!NILP (ii->name))
576 {
577 print_internal (ii->name, printcharfun, 1);
578 write_c_string (" ", printcharfun);
579 }
580 write_c_string ("on ", printcharfun);
581 print_internal (ii->device, printcharfun, 0);
582 write_c_string (" ", printcharfun);
583 switch (IMAGE_INSTANCE_TYPE (ii))
584 {
585 case IMAGE_NOTHING:
586 break;
587
588 case IMAGE_TEXT:
589 print_internal (IMAGE_INSTANCE_TEXT_STRING (ii), printcharfun, 1);
590 break;
591
592 case IMAGE_MONO_PIXMAP:
593 case IMAGE_COLOR_PIXMAP:
594 case IMAGE_POINTER:
595 if (STRINGP (IMAGE_INSTANCE_PIXMAP_FILENAME (ii)))
596 {
597 char *s;
598 Lisp_Object filename = IMAGE_INSTANCE_PIXMAP_FILENAME (ii);
599 s = strrchr ((char *) string_data (XSTRING (filename)), '/');
600 if (s)
601 print_internal (build_string (s + 1), printcharfun, 1);
602 else
603 print_internal (filename, printcharfun, 1);
604 }
605 if (IMAGE_INSTANCE_PIXMAP_DEPTH (ii) > 1)
606 sprintf (buf, " %dx%dx%d", IMAGE_INSTANCE_PIXMAP_WIDTH (ii),
607 IMAGE_INSTANCE_PIXMAP_HEIGHT (ii),
608 IMAGE_INSTANCE_PIXMAP_DEPTH (ii));
609 else
610 sprintf (buf, " %dx%d", IMAGE_INSTANCE_PIXMAP_WIDTH (ii),
611 IMAGE_INSTANCE_PIXMAP_HEIGHT (ii));
612 write_c_string (buf, printcharfun);
613 if (!NILP (IMAGE_INSTANCE_PIXMAP_HOTSPOT_X (ii)) ||
614 !NILP (IMAGE_INSTANCE_PIXMAP_HOTSPOT_Y (ii)))
615 {
616 write_c_string (" @", printcharfun);
617 if (!NILP (IMAGE_INSTANCE_PIXMAP_HOTSPOT_X (ii)))
618 {
619 sprintf (buf, "%d", XINT (IMAGE_INSTANCE_PIXMAP_HOTSPOT_X (ii)));
620 write_c_string (buf, printcharfun);
621 }
622 else
623 write_c_string ("??", printcharfun);
624 write_c_string (",", printcharfun);
625 if (!NILP (IMAGE_INSTANCE_PIXMAP_HOTSPOT_Y (ii)))
626 {
627 sprintf (buf, "%d", XINT (IMAGE_INSTANCE_PIXMAP_HOTSPOT_Y (ii)));
628 write_c_string (buf, printcharfun);
629 }
630 else
631 write_c_string ("??", printcharfun);
632 }
633 if (!NILP (IMAGE_INSTANCE_PIXMAP_FG (ii)) ||
634 !NILP (IMAGE_INSTANCE_PIXMAP_BG (ii)))
635 {
636 write_c_string (" (", printcharfun);
637 if (!NILP (IMAGE_INSTANCE_PIXMAP_FG (ii)))
638 {
639 print_internal
640 (XCOLOR_INSTANCE
641 (IMAGE_INSTANCE_PIXMAP_FG (ii))->name, printcharfun, 0);
642 }
643 write_c_string ("/", printcharfun);
644 if (!NILP (IMAGE_INSTANCE_PIXMAP_BG (ii)))
645 {
646 print_internal
647 (XCOLOR_INSTANCE
648 (IMAGE_INSTANCE_PIXMAP_BG (ii))->name, printcharfun, 0);
649 }
650 write_c_string (")", printcharfun);
651 }
652 break;
653
654 case IMAGE_SUBWINDOW:
655 /* #### implement me */
656 break;
657
658 default:
659 abort ();
660 }
661
662 MAYBE_DEVMETH (XDEVICE (ii->device), print_image_instance,
663 (ii, printcharfun, escapeflag));
664 sprintf (buf, " 0x%x>", ii->header.uid);
665 write_c_string (buf, printcharfun);
666 }
667
668 static void
669 finalize_image_instance (void *header, int for_disksave)
670 {
671 struct Lisp_Image_Instance *i = (struct Lisp_Image_Instance *) header;
672
673 if (IMAGE_INSTANCE_TYPE (i) == IMAGE_NOTHING)
674 /* objects like this exist at dump time, so don't bomb out. */
675 return;
676 if (for_disksave) finalose (i);
677
678 MAYBE_DEVMETH (XDEVICE (i->device), finalize_image_instance, (i));
679 }
680
681 static int
682 image_instance_equal (Lisp_Object o1, Lisp_Object o2, int depth)
683 {
684 struct Lisp_Image_Instance *i1 = XIMAGE_INSTANCE (o1);
685 struct Lisp_Image_Instance *i2 = XIMAGE_INSTANCE (o2);
686 struct device *d1 = XDEVICE (i1->device);
687 struct device *d2 = XDEVICE (i2->device);
688
689 if (d1 != d2)
690 return 0;
691 if (IMAGE_INSTANCE_TYPE (i1) != IMAGE_INSTANCE_TYPE (i2))
692 return 0;
693 if (!internal_equal (IMAGE_INSTANCE_NAME (i1), IMAGE_INSTANCE_NAME (i2),
694 depth + 1))
695 return 0;
696
697 switch (IMAGE_INSTANCE_TYPE (i1))
698 {
699 case IMAGE_NOTHING:
700 break;
701
702 case IMAGE_TEXT:
703 if (!internal_equal (IMAGE_INSTANCE_TEXT_STRING (i1),
704 IMAGE_INSTANCE_TEXT_STRING (i2),
705 depth + 1))
706 return 0;
707 break;
708
709 case IMAGE_MONO_PIXMAP:
710 case IMAGE_COLOR_PIXMAP:
711 case IMAGE_POINTER:
712 if (!(IMAGE_INSTANCE_PIXMAP_WIDTH (i1) ==
713 IMAGE_INSTANCE_PIXMAP_WIDTH (i2) &&
714 IMAGE_INSTANCE_PIXMAP_HEIGHT (i1) ==
715 IMAGE_INSTANCE_PIXMAP_HEIGHT (i2) &&
716 IMAGE_INSTANCE_PIXMAP_DEPTH (i1) ==
717 IMAGE_INSTANCE_PIXMAP_DEPTH (i2) &&
718 EQ (IMAGE_INSTANCE_PIXMAP_HOTSPOT_X (i1),
719 IMAGE_INSTANCE_PIXMAP_HOTSPOT_X (i2)) &&
720 EQ (IMAGE_INSTANCE_PIXMAP_HOTSPOT_Y (i1),
721 IMAGE_INSTANCE_PIXMAP_HOTSPOT_Y (i2)) &&
722 internal_equal (IMAGE_INSTANCE_PIXMAP_FILENAME (i1),
723 IMAGE_INSTANCE_PIXMAP_FILENAME (i2),
724 depth + 1) &&
725 internal_equal (IMAGE_INSTANCE_PIXMAP_MASK_FILENAME (i1),
726 IMAGE_INSTANCE_PIXMAP_MASK_FILENAME (i2),
727 depth + 1)))
728 return 0;
729 break;
730
731 case IMAGE_SUBWINDOW:
732 /* #### implement me */
733 break;
734
735 default:
736 abort ();
737 }
738
739 return DEVMETH_OR_GIVEN (d1, image_instance_equal, (i1, i2, depth), 1);
740 }
741
742 static unsigned long
743 image_instance_hash (Lisp_Object obj, int depth)
744 {
745 struct Lisp_Image_Instance *i = XIMAGE_INSTANCE (obj);
746 struct device *d = XDEVICE (i->device);
747 unsigned long hash = (unsigned long) d;
748
749 switch (IMAGE_INSTANCE_TYPE (i))
750 {
751 case IMAGE_NOTHING:
752 break;
753
754 case IMAGE_TEXT:
755 hash = HASH2 (hash, internal_hash (IMAGE_INSTANCE_TEXT_STRING (i),
756 depth + 1));
757 break;
758
759 case IMAGE_MONO_PIXMAP:
760 case IMAGE_COLOR_PIXMAP:
761 case IMAGE_POINTER:
762 hash = HASH5 (hash, IMAGE_INSTANCE_PIXMAP_WIDTH (i),
763 IMAGE_INSTANCE_PIXMAP_HEIGHT (i),
764 IMAGE_INSTANCE_PIXMAP_DEPTH (i),
765 internal_hash (IMAGE_INSTANCE_PIXMAP_FILENAME (i),
766 depth + 1));
767 break;
768
769 case IMAGE_SUBWINDOW:
770 /* #### implement me */
771 break;
772
773 default:
774 abort ();
775 }
776
777 return HASH2 (hash, DEVMETH_OR_GIVEN (d, image_instance_hash, (i, depth),
778 0));
779 }
780
781 static Lisp_Object
782 allocate_image_instance (Lisp_Object device)
783 {
784 struct Lisp_Image_Instance *lp =
785 alloc_lcrecord (sizeof (struct Lisp_Image_Instance),
786 lrecord_image_instance);
787 Lisp_Object val = Qnil;
788
789 zero_lcrecord (lp);
790 lp->device = device;
791 lp->type = IMAGE_NOTHING;
792 lp->name = Qnil;
793 XSETIMAGE_INSTANCE (val, lp);
794 return val;
795 }
796
797 static enum image_instance_type
798 decode_image_instance_type (Lisp_Object type, Error_behavior errb)
799 {
800 if (ERRB_EQ (errb, ERROR_ME))
801 CHECK_SYMBOL (type);
802
803 if (EQ (type, Qnothing))
804 return IMAGE_NOTHING;
805 if (EQ (type, Qtext))
806 return IMAGE_TEXT;
807 if (EQ (type, Qmono_pixmap))
808 return IMAGE_MONO_PIXMAP;
809 if (EQ (type, Qcolor_pixmap))
810 return IMAGE_COLOR_PIXMAP;
811 if (EQ (type, Qpointer))
812 return IMAGE_POINTER;
813 if (EQ (type, Qsubwindow))
814 return IMAGE_SUBWINDOW;
815
816 maybe_signal_simple_error ("Invalid image-instance type", type,
817 Qimage, errb);
818 return IMAGE_UNKNOWN;
819 }
820
821 static Lisp_Object
822 encode_image_instance_type (enum image_instance_type type)
823 {
824 switch (type)
825 {
826 case IMAGE_NOTHING:
827 return Qnothing;
828 case IMAGE_TEXT:
829 return Qtext;
830 case IMAGE_MONO_PIXMAP:
831 return Qmono_pixmap;
832 case IMAGE_COLOR_PIXMAP:
833 return Qcolor_pixmap;
834 case IMAGE_POINTER:
835 return Qpointer;
836 case IMAGE_SUBWINDOW:
837 return Qsubwindow;
838 default:
839 abort ();
840 }
841
842 return Qnil; /* not reached */
843 }
844
845 static int
846 image_instance_type_to_mask (enum image_instance_type type)
847 {
848 /* This depends on the fact that enums are assigned consecutive
849 integers starting at 0. (Remember that IMAGE_UNKNOWN is the
850 first enum.) I'm fairly sure this behavior in ANSI-mandated,
851 so there should be no portability problems here. */
852 return (1 << ((int) (type) - 1));
853 }
854
855 static int
856 decode_image_instance_type_list (Lisp_Object list)
857 {
858 Lisp_Object rest;
859 int mask = 0;
860
861 if (NILP (list))
862 return ~0;
863
864 if (!CONSP (list))
865 {
866 enum image_instance_type type =
867 decode_image_instance_type (list, ERROR_ME);
868 return image_instance_type_to_mask (type);
869 }
870
871 EXTERNAL_LIST_LOOP (rest, list)
872 {
873 enum image_instance_type type =
874 decode_image_instance_type (XCAR (rest), ERROR_ME);
875 mask |= image_instance_type_to_mask (type);
876 }
877
878 return mask;
879 }
880
881 static Lisp_Object
882 encode_image_instance_type_list (int mask)
883 {
884 int count = 0;
885 Lisp_Object result = Qnil;
886
887 while (mask)
888 {
889 count++;
890 if (mask & 1)
891 result = Fcons (encode_image_instance_type
892 ((enum image_instance_type) count), result);
893 mask >>= 1;
894 }
895
896 return Fnreverse (result);
897 }
898
899 DOESNT_RETURN
900 incompatible_image_types (Lisp_Object instantiator, int given_dest_mask,
901 int desired_dest_mask)
902 {
903 signal_error
904 (Qerror,
905 list2
906 (emacs_doprnt_string_lisp_2
907 ((CONST Bufbyte *)
908 "No compatible image-instance types given: wanted one of %s, got %s",
909 Qnil, -1, 2,
910 encode_image_instance_type_list (desired_dest_mask),
911 encode_image_instance_type_list (given_dest_mask)),
912 instantiator));
913 }
914
915 static int
916 valid_image_instance_type_p (Lisp_Object type)
917 {
918 if (!NILP (memq_no_quit (type, Vimage_instance_type_list)))
919 return 1;
920 return 0;
921 }
922
923 DEFUN ("valid-image-instance-type-p", Fvalid_image_instance_type_p,
924 Svalid_image_instance_type_p, 1, 1, 0 /*
925 Given an IMAGE-INSTANCE-TYPE, return non-nil if it is valid.
926 Valid types are some subset of 'nothing, 'text, 'mono-pixmap, 'color-pixmap,
927 'pointer, and 'subwindow, depending on how XEmacs was compiled.
928 */ )
929 (image_instance_type)
930 Lisp_Object image_instance_type;
931 {
932 if (valid_image_instance_type_p (image_instance_type))
933 return Qt;
934 else
935 return Qnil;
936 }
937
938 DEFUN ("image-instance-type-list", Fimage_instance_type_list,
939 Simage_instance_type_list,
940 0, 0, 0 /*
941 Return a list of valid image-instance types.
942 */ )
943 ()
944 {
945 return Fcopy_sequence (Vimage_instance_type_list);
946 }
947
948 Error_behavior
949 decode_error_behavior_flag (Lisp_Object no_error)
950 {
951 if (NILP (no_error))
952 return ERROR_ME;
953 else if (EQ (no_error, Qt))
954 return ERROR_ME_NOT;
955 else
956 return ERROR_ME_WARN;
957 }
958
959 Lisp_Object
960 encode_error_behavior_flag (Error_behavior errb)
961 {
962 if (ERRB_EQ (errb, ERROR_ME))
963 return Qnil;
964 else if (ERRB_EQ (errb, ERROR_ME_NOT))
965 return Qt;
966 else
967 {
968 assert (ERRB_EQ (errb, ERROR_ME_WARN));
969 return Qwarning;
970 }
971 }
972
973 static Lisp_Object
974 make_image_instance_1 (Lisp_Object data, Lisp_Object device,
975 Lisp_Object dest_types)
976 {
977 Lisp_Object ii;
978 struct gcpro gcpro1;
979 int dest_mask;
980
981 XSETDEVICE (device, decode_device (device));
982 /* instantiate_image_instantiator() will abort if given an
983 image instance ... */
984 if (IMAGE_INSTANCEP (data))
985 signal_simple_error ("image instances not allowed here", data);
986 image_validate (data);
987 dest_mask = decode_image_instance_type_list (dest_types);
988 data = normalize_image_instantiator (data, DEVICE_TYPE (XDEVICE (device)),
989 make_int (dest_mask));
990 GCPRO1 (data);
991 if (VECTORP (data)
992 && EQ (vector_data (XVECTOR (data))[0], Qinherit))
993 signal_simple_error ("inheritance not allowed here", data);
994 ii = instantiate_image_instantiator (device, data, Qnil, Qnil, dest_mask);
995 RETURN_UNGCPRO (ii);
996 }
997
998 DEFUN ("make-image-instance", Fmake_image_instance, Smake_image_instance,
999 1, 4, 0 /*
1000 Create a new `image-instance' object.
1001
1002 Image-instance objects encapsulate the way a particular image (pixmap,
1003 etc.) is displayed on a particular device. In most circumstances, you
1004 do not need to directly create image instances; use a glyph instead.
1005 However, it may occasionally be useful to explicitly create image
1006 instances, if you want more control over the instantiation process.
1007
1008 DATA is an image instantiator, which describes the image; see
1009 `image-specifier-p' for a description of the allowed values.
1010
1011 DEST-TYPES should be a list of allowed image instance types that can
1012 be generated. The recognized image instance types are
1013
1014 'nothing
1015 Nothing is displayed.
1016 'text
1017 Displayed as text. The foreground and background colors and the
1018 font of the text are specified independent of the pixmap. Typically
1019 these attributes will come from the face of the surrounding text,
1020 unless a face is specified for the glyph in which the image appears.
1021 'mono-pixmap
1022 Displayed as a mono pixmap (a pixmap with only two colors where the
1023 foreground and background can be specified independent of the pixmap;
1024 typically the pixmap assumes the foreground and background colors of
1025 the text around it, unless a face is specified for the glyph in which
1026 the image appears).
1027 'color-pixmap
1028 Displayed as a color pixmap.
1029 'pointer
1030 Used as the mouse pointer for a window.
1031 'subwindow
1032 A child window that is treated as an image. This allows (e.g.)
1033 another program to be responsible for drawing into the window.
1034 Not currently implemented.
1035
1036 The DEST-TYPES list is unordered. If multiple destination types
1037 are possible for a given instantiator, the \"most natural\" type
1038 for the instantiator's format is chosen. (For XBM, the most natural
1039 types are `mono-pixmap', followed by `color-pixmap', followed by
1040 `pointer'. For the other normal image formats, the most natural
1041 types are `color-pixmap', followed by `mono-pixmap', followed by
1042 `pointer'. For the string and formatted-string formats, the most
1043 natural types are `text', followed by `mono-pixmap' (not currently
1044 implemented), followed by `color-pixmap' (not currently implemented).
1045 The other formats can only be instantiated as one type. (If you
1046 want to control more specifically the order of the types into which
1047 an image is instantiated, just call `make-image-instance' repeatedly
1048 until it succeeds, passing less and less preferred destination types
1049 each time.
1050
1051 If DEST-TYPES is omitted, all possible types are allowed.
1052
1053 NO-ERROR controls what happens when the image cannot be generated.
1054 If nil, an error message is generated. If t, no messages are
1055 generated and this function returns nil. If anything else, a warning
1056 message is generated and this function returns nil.
1057 */ )
1058 (data, device, dest_types, no_error)
1059 Lisp_Object data, device, dest_types, no_error;
1060 {
1061 Error_behavior errb = decode_error_behavior_flag (no_error);
1062
1063 return call_with_suspended_errors (make_image_instance_1,
1064 Qnil, Qimage, errb,
1065 3, data, device, dest_types);
1066 }
1067
1068 DEFUN ("image-instance-p", Fimage_instance_p, Simage_instance_p, 1, 1, 0 /*
1069 Return non-nil if OBJECT is an image instance.
1070 */ )
1071 (object)
1072 Lisp_Object object;
1073 {
1074 return (IMAGE_INSTANCEP (object) ? Qt : Qnil);
1075 }
1076
1077 DEFUN ("image-instance-type", Fimage_instance_type, Simage_instance_type,
1078 1, 1, 0 /*
1079 Return the type of the given image instance.
1080 The return value will be one of 'nothing, 'text, 'mono-pixmap,
1081 'color-pixmap, 'pointer, or 'subwindow.
1082 */ )
1083 (image_instance)
1084 Lisp_Object image_instance;
1085 {
1086 CHECK_IMAGE_INSTANCE (image_instance);
1087 return encode_image_instance_type (XIMAGE_INSTANCE_TYPE (image_instance));
1088 }
1089
1090 DEFUN ("image-instance-name", Fimage_instance_name,
1091 Simage_instance_name, 1, 1, 0 /*
1092 Return the name of the given image instance.
1093 */ )
1094 (image_instance)
1095 Lisp_Object image_instance;
1096 {
1097 CHECK_IMAGE_INSTANCE (image_instance);
1098 return (XIMAGE_INSTANCE_NAME (image_instance));
1099 }
1100
1101 DEFUN ("image-instance-string", Fimage_instance_string,
1102 Simage_instance_string, 1, 1, 0 /*
1103 Return the string of the given image instance.
1104 This will only be non-nil for text image instances.
1105 */ )
1106 (image_instance)
1107 Lisp_Object image_instance;
1108 {
1109 CHECK_IMAGE_INSTANCE (image_instance);
1110 if (XIMAGE_INSTANCE_TYPE (image_instance) == IMAGE_TEXT)
1111 return (XIMAGE_INSTANCE_TEXT_STRING (image_instance));
1112 else
1113 return Qnil;
1114 }
1115
1116 DEFUN ("image-instance-file-name", Fimage_instance_file_name,
1117 Simage_instance_file_name, 1, 1, 0 /*
1118 Return the file name from which IMAGE-INSTANCE was read, if known.
1119 */ )
1120 (image_instance)
1121 Lisp_Object image_instance;
1122 {
1123 CHECK_IMAGE_INSTANCE (image_instance);
1124
1125 switch (XIMAGE_INSTANCE_TYPE (image_instance))
1126 {
1127 case IMAGE_MONO_PIXMAP:
1128 case IMAGE_COLOR_PIXMAP:
1129 case IMAGE_POINTER:
1130 return XIMAGE_INSTANCE_PIXMAP_FILENAME (image_instance);
1131
1132 default:
1133 return Qnil;
1134 }
1135 }
1136
1137 DEFUN ("image-instance-mask-file-name", Fimage_instance_mask_file_name,
1138 Simage_instance_mask_file_name, 1, 1, 0 /*
1139 Return the file name from which IMAGE-INSTANCE's mask was read, if known.
1140 */ )
1141 (image_instance)
1142 Lisp_Object image_instance;
1143 {
1144 CHECK_IMAGE_INSTANCE (image_instance);
1145
1146 switch (XIMAGE_INSTANCE_TYPE (image_instance))
1147 {
1148 case IMAGE_MONO_PIXMAP:
1149 case IMAGE_COLOR_PIXMAP:
1150 case IMAGE_POINTER:
1151 return XIMAGE_INSTANCE_PIXMAP_MASK_FILENAME (image_instance);
1152
1153 default:
1154 return Qnil;
1155 }
1156 }
1157
1158 DEFUN ("image-instance-depth", Fimage_instance_depth,
1159 Simage_instance_depth, 1, 1, 0 /*
1160 Return the depth of the image instance.
1161 This is 0 for a bitmap, or a positive integer for a pixmap.
1162 */ )
1163 (image_instance)
1164 Lisp_Object image_instance;
1165 {
1166 CHECK_IMAGE_INSTANCE (image_instance);
1167
1168 switch (XIMAGE_INSTANCE_TYPE (image_instance))
1169 {
1170 case IMAGE_MONO_PIXMAP:
1171 case IMAGE_COLOR_PIXMAP:
1172 case IMAGE_POINTER:
1173 return (make_int (XIMAGE_INSTANCE_PIXMAP_DEPTH (image_instance)));
1174
1175 default:
1176 return Qnil;
1177 }
1178 }
1179
1180 DEFUN ("image-instance-height", Fimage_instance_height,
1181 Simage_instance_height, 1, 1, 0 /*
1182 Return the height of the image instance, in pixels.
1183 */ )
1184 (image_instance)
1185 Lisp_Object image_instance;
1186 {
1187 CHECK_IMAGE_INSTANCE (image_instance);
1188
1189 switch (XIMAGE_INSTANCE_TYPE (image_instance))
1190 {
1191 case IMAGE_MONO_PIXMAP:
1192 case IMAGE_COLOR_PIXMAP:
1193 case IMAGE_POINTER:
1194 return (make_int (XIMAGE_INSTANCE_PIXMAP_HEIGHT (image_instance)));
1195
1196 default:
1197 return Qnil;
1198 }
1199 }
1200
1201 DEFUN ("image-instance-width", Fimage_instance_width,
1202 Simage_instance_width, 1, 1, 0 /*
1203 Return the width of the image instance, in pixels.
1204 */ )
1205 (image_instance)
1206 Lisp_Object image_instance;
1207 {
1208 CHECK_IMAGE_INSTANCE (image_instance);
1209
1210 switch (XIMAGE_INSTANCE_TYPE (image_instance))
1211 {
1212 case IMAGE_MONO_PIXMAP:
1213 case IMAGE_COLOR_PIXMAP:
1214 case IMAGE_POINTER:
1215 return (make_int (XIMAGE_INSTANCE_PIXMAP_WIDTH (image_instance)));
1216
1217 default:
1218 return Qnil;
1219 }
1220 }
1221
1222 DEFUN ("image-instance-hotspot-x", Fimage_instance_hotspot_x,
1223 Simage_instance_hotspot_x, 1, 1, 0 /*
1224 Return the X coordinate of the image instance's hotspot, if known.
1225 This is a point relative to the origin of the pixmap. When an image is
1226 used as a mouse pointer, the hotspot is the point on the image that sits
1227 over the location that the pointer points to. This is, for example, the
1228 tip of the arrow or the center of the crosshairs.
1229 This will always be nil for a non-pointer image instance.
1230 */ )
1231 (image_instance)
1232 Lisp_Object image_instance;
1233 {
1234 CHECK_IMAGE_INSTANCE (image_instance);
1235
1236 switch (XIMAGE_INSTANCE_TYPE (image_instance))
1237 {
1238 case IMAGE_MONO_PIXMAP:
1239 case IMAGE_COLOR_PIXMAP:
1240 case IMAGE_POINTER:
1241 return XIMAGE_INSTANCE_PIXMAP_HOTSPOT_X (image_instance);
1242
1243 default:
1244 return Qnil;
1245 }
1246 }
1247
1248 DEFUN ("image-instance-hotspot-y", Fimage_instance_hotspot_y,
1249 Simage_instance_hotspot_y, 1, 1, 0 /*
1250 Return the Y coordinate of the image instance's hotspot, if known.
1251 This is a point relative to the origin of the pixmap. When an image is
1252 used as a mouse pointer, the hotspot is the point on the image that sits
1253 over the location that the pointer points to. This is, for example, the
1254 tip of the arrow or the center of the crosshairs.
1255 This will always be nil for a non-pointer image instance.
1256 */ )
1257 (image_instance)
1258 Lisp_Object image_instance;
1259 {
1260 CHECK_IMAGE_INSTANCE (image_instance);
1261
1262 switch (XIMAGE_INSTANCE_TYPE (image_instance))
1263 {
1264 case IMAGE_MONO_PIXMAP:
1265 case IMAGE_COLOR_PIXMAP:
1266 case IMAGE_POINTER:
1267 return XIMAGE_INSTANCE_PIXMAP_HOTSPOT_Y (image_instance);
1268
1269 default:
1270 return Qnil;
1271 }
1272 }
1273
1274 DEFUN ("image-instance-foreground", Fimage_instance_foreground,
1275 Simage_instance_foreground, 1, 1, 0 /*
1276 Return the foreground color of IMAGE-INSTANCE, if applicable.
1277 This will be a color instance or nil. (It will only be non-nil for
1278 colorized mono pixmaps and for pointers.)
1279 */ )
1280 (image_instance)
1281 Lisp_Object image_instance;
1282 {
1283 CHECK_IMAGE_INSTANCE (image_instance);
1284
1285 switch (XIMAGE_INSTANCE_TYPE (image_instance))
1286 {
1287 case IMAGE_MONO_PIXMAP:
1288 case IMAGE_COLOR_PIXMAP:
1289 case IMAGE_POINTER:
1290 return XIMAGE_INSTANCE_PIXMAP_FG (image_instance);
1291
1292 default:
1293 return Qnil;
1294 }
1295 }
1296
1297 DEFUN ("image-instance-background", Fimage_instance_background,
1298 Simage_instance_background, 1, 1, 0 /*
1299 Return the background color of IMAGE-INSTANCE, if applicable.
1300 This will be a color instance or nil. (It will only be non-nil for
1301 colorized mono pixmaps and for pointers.)
1302 */ )
1303 (image_instance)
1304 Lisp_Object image_instance;
1305 {
1306 CHECK_IMAGE_INSTANCE (image_instance);
1307
1308 switch (XIMAGE_INSTANCE_TYPE (image_instance))
1309 {
1310 case IMAGE_MONO_PIXMAP:
1311 case IMAGE_COLOR_PIXMAP:
1312 case IMAGE_POINTER:
1313 return XIMAGE_INSTANCE_PIXMAP_BG (image_instance);
1314
1315 default:
1316 return Qnil;
1317 }
1318 }
1319
1320
1321 DEFUN ("colorize-image-instance", Fcolorize_image_instance,
1322 Scolorize_image_instance, 3, 3, 0 /*
1323 Make the image instance be displayed in the given colors.
1324 This function returns a new image instance that is exactly like the
1325 specified one except that (if possible) the foreground and background
1326 colors and as specified. Currently, this only does anything if the image
1327 instance is a mono pixmap; otherwise, the same image instance is returned.
1328 */ )
1329 (image_instance, foreground, background)
1330 Lisp_Object image_instance, foreground, background;
1331 {
1332 Lisp_Object new;
1333 Lisp_Object device;
1334
1335 CHECK_IMAGE_INSTANCE (image_instance);
1336 CHECK_COLOR_INSTANCE (foreground);
1337 CHECK_COLOR_INSTANCE (background);
1338
1339 device = XIMAGE_INSTANCE_DEVICE (image_instance);
1340 if (!HAS_DEVMETH_P (XDEVICE (device), colorize_image_instance))
1341 return image_instance;
1342
1343 new = allocate_image_instance (device);
1344 copy_lcrecord (XIMAGE_INSTANCE (new), XIMAGE_INSTANCE (image_instance));
1345 /* note that if this method returns non-zero, this method MUST
1346 copy any window-system resources, so that when one image instance is
1347 freed, the other one is not hosed. */
1348 if (!DEVMETH (XDEVICE (device), colorize_image_instance, (new, foreground,
1349 background)))
1350 return image_instance;
1351 return new;
1352 }
1353
1354
1355 /****************************************************************************
1356 * nothing *
1357 ****************************************************************************/
1358
1359 static int
1360 nothing_possible_dest_types ()
1361 {
1362 return IMAGE_NOTHING_MASK;
1363 }
1364
1365 static void
1366 nothing_instantiate (Lisp_Object image_instance, Lisp_Object instantiator,
1367 Lisp_Object pointer_fg, Lisp_Object pointer_bg,
1368 int dest_mask)
1369 {
1370 struct Lisp_Image_Instance *ii = XIMAGE_INSTANCE (image_instance);
1371
1372 if (dest_mask & IMAGE_NOTHING_MASK)
1373 IMAGE_INSTANCE_TYPE (ii) = IMAGE_NOTHING;
1374 else
1375 incompatible_image_types (instantiator, dest_mask, IMAGE_NOTHING_MASK);
1376 }
1377
1378
1379 /****************************************************************************
1380 * inherit *
1381 ****************************************************************************/
1382
1383 static void
1384 inherit_validate (Lisp_Object instantiator)
1385 {
1386 face_must_be_present (instantiator);
1387 }
1388
1389 static Lisp_Object
1390 inherit_normalize (Lisp_Object inst, Lisp_Object console_type)
1391 {
1392 Lisp_Object face;
1393
1394 assert (XVECTOR (inst)->size == 3);
1395 face = vector_data (XVECTOR (inst))[2];
1396 if (!FACEP (face))
1397 inst = vector3 (Qinherit, Q_face, Fget_face (face));
1398 return inst;
1399 }
1400
1401 static int
1402 inherit_possible_dest_types ()
1403 {
1404 return IMAGE_MONO_PIXMAP_MASK;
1405 }
1406
1407 static void
1408 inherit_instantiate (Lisp_Object image_instance, Lisp_Object instantiator,
1409 Lisp_Object pointer_fg, Lisp_Object pointer_bg,
1410 int dest_mask)
1411 {
1412 /* handled specially in image_instantiate */
1413 abort ();
1414 }
1415
1416
1417 /****************************************************************************
1418 * string *
1419 ****************************************************************************/
1420
1421 static void
1422 string_validate (Lisp_Object instantiator)
1423 {
1424 data_must_be_present (instantiator);
1425 }
1426
1427 static int
1428 string_possible_dest_types ()
1429 {
1430 return IMAGE_TEXT_MASK;
1431 }
1432
1433 /* called from autodetect_instantiate() */
1434 void
1435 string_instantiate (Lisp_Object image_instance, Lisp_Object instantiator,
1436 Lisp_Object pointer_fg, Lisp_Object pointer_bg,
1437 int dest_mask)
1438 {
1439 Lisp_Object data = find_keyword_in_vector (instantiator, Q_data);
1440 struct Lisp_Image_Instance *ii = XIMAGE_INSTANCE (image_instance);
1441
1442 assert (!NILP (data));
1443 if (dest_mask & IMAGE_TEXT_MASK)
1444 {
1445 IMAGE_INSTANCE_TYPE (ii) = IMAGE_TEXT;
1446 IMAGE_INSTANCE_TEXT_STRING (ii) = data;
1447 }
1448 else
1449 incompatible_image_types (instantiator, dest_mask, IMAGE_TEXT_MASK);
1450 }
1451
1452
1453 /****************************************************************************
1454 * formatted-string *
1455 ****************************************************************************/
1456
1457 static void
1458 formatted_string_validate (Lisp_Object instantiator)
1459 {
1460 data_must_be_present (instantiator);
1461 }
1462
1463 static int
1464 formatted_string_possible_dest_types ()
1465 {
1466 return IMAGE_TEXT_MASK;
1467 }
1468
1469 static void
1470 formatted_string_instantiate (Lisp_Object image_instance,
1471 Lisp_Object instantiator,
1472 Lisp_Object pointer_fg, Lisp_Object pointer_bg,
1473 int dest_mask)
1474 {
1475 Lisp_Object data = find_keyword_in_vector (instantiator, Q_data);
1476 struct Lisp_Image_Instance *ii = XIMAGE_INSTANCE (image_instance);
1477
1478 assert (!NILP (data));
1479 /* #### implement this */
1480 warn_when_safe (Qunimplemented, Qnotice,
1481 "`formatted-string' not yet implemented; assuming `string'");
1482 if (dest_mask & IMAGE_TEXT_MASK)
1483 {
1484 IMAGE_INSTANCE_TYPE (ii) = IMAGE_TEXT;
1485 IMAGE_INSTANCE_TEXT_STRING (ii) = data;
1486 }
1487 else
1488 incompatible_image_types (instantiator, dest_mask, IMAGE_TEXT_MASK);
1489 }
1490
1491
1492 /****************************************************************************
1493 * Image Specifier Object *
1494 ****************************************************************************/
1495
1496 DEFINE_SPECIFIER_TYPE (image);
1497
1498 static void
1499 image_create (Lisp_Object obj)
1500 {
1501 struct Lisp_Specifier *image = XIMAGE_SPECIFIER (obj);
1502
1503 IMAGE_SPECIFIER_ALLOWED (image) = ~0; /* all are allowed */
1504 IMAGE_SPECIFIER_ATTACHEE (image) = Qnil;
1505 IMAGE_SPECIFIER_ATTACHEE_PROPERTY (image) = Qnil;
1506 }
1507
1508 static void
1509 image_mark (Lisp_Object obj, void (*markobj) (Lisp_Object))
1510 {
1511 struct Lisp_Specifier *image = XIMAGE_SPECIFIER (obj);
1512
1513 ((markobj) (IMAGE_SPECIFIER_ATTACHEE (image)));
1514 ((markobj) (IMAGE_SPECIFIER_ATTACHEE_PROPERTY (image)));
1515 }
1516
1517 static Lisp_Object
1518 image_instantiate_cache_result (Lisp_Object locative)
1519 {
1520 Lisp_Object instance = Fcar (locative);
1521 Lisp_Object instantiator = Fcar (Fcdr (locative));
1522 Lisp_Object subtable = Fcdr (Fcdr (locative));
1523 Fputhash (instantiator, instance, subtable);
1524 free_cons (XCONS (XCDR (locative)));
1525 free_cons (XCONS (locative));
1526 return Qnil;
1527 }
1528
1529 /* Given a specification for an image, return an instance of
1530 the image which matches the given instantiator and which can be
1531 displayed in the given domain. */
1532
1533 static Lisp_Object
1534 image_instantiate (Lisp_Object specifier, Lisp_Object matchspec,
1535 Lisp_Object domain, Lisp_Object instantiator,
1536 Lisp_Object depth)
1537 {
1538 Lisp_Object device = DFW_DEVICE (domain);
1539 struct device *d = XDEVICE (device);
1540 int dest_mask = XIMAGE_SPECIFIER_ALLOWED (specifier);
1541 int pointerp = dest_mask & image_instance_type_to_mask (IMAGE_POINTER);
1542
1543 if (IMAGE_INSTANCEP (instantiator))
1544 {
1545 /* make sure that the image instance's device and type are
1546 matching. */
1547
1548 if (EQ (device, XIMAGE_INSTANCE_DEVICE (instantiator)))
1549 {
1550 int mask =
1551 image_instance_type_to_mask (XIMAGE_INSTANCE_TYPE (instantiator));
1552 if (mask & dest_mask)
1553 return instantiator;
1554 else
1555 signal_simple_error ("Type of image instance not allowed here",
1556 instantiator);
1557 }
1558 else
1559 signal_simple_error_2 ("Wrong device for image instance",
1560 instantiator, device);
1561 }
1562 else if (VECTORP (instantiator)
1563 && EQ (vector_data (XVECTOR (instantiator))[0], Qinherit))
1564 {
1565 assert (XVECTOR (instantiator)->size == 3);
1566 return (FACE_PROPERTY_INSTANCE
1567 (Fget_face (vector_data (XVECTOR (instantiator))[2]),
1568 Qbackground_pixmap, domain, 0, depth));
1569 }
1570 else
1571 {
1572 Lisp_Object instance;
1573 Lisp_Object subtable;
1574 Lisp_Object ls3 = Qnil;
1575 Lisp_Object pointer_fg = Qnil;
1576 Lisp_Object pointer_bg = Qnil;
1577
1578 if (pointerp)
1579 {
1580 pointer_fg = FACE_FOREGROUND (Vpointer_face, domain);
1581 pointer_bg = FACE_BACKGROUND (Vpointer_face, domain);
1582 ls3 = list3 (instantiator, pointer_fg, pointer_bg);
1583 }
1584
1585 /* First look in the hash table. */
1586 subtable = Fgethash (make_int (dest_mask), d->image_instance_cache,
1587 Qunbound);
1588 if (UNBOUNDP (subtable))
1589 {
1590 /* For the image instance cache, we do comparisons with EQ rather
1591 than with EQUAL, as we do for color and font names.
1592 The reasons are:
1593
1594 1) pixmap data can be very long, and thus the hashing and
1595 comparing will take awhile.
1596 2) It's not so likely that we'll run into things that are EQUAL
1597 but not EQ (that can happen a lot with faces, because their
1598 specifiers are copied around); but pixmaps tend not to be
1599 in faces.
1600
1601 However, if the image-instance could be a pointer, we have to
1602 use EQUAL because we massaged the instantiator into a cons3
1603 also containing the foreground and background of the
1604 pointer face.
1605 */
1606
1607 subtable = make_lisp_hashtable (20,
1608 pointerp ? HASHTABLE_KEY_CAR_WEAK
1609 : HASHTABLE_KEY_WEAK,
1610 pointerp ? HASHTABLE_EQUAL
1611 : HASHTABLE_EQ);
1612 Fputhash (make_int (dest_mask), subtable,
1613 d->image_instance_cache);
1614 instance = Qunbound;
1615 }
1616 else
1617 instance = Fgethash (pointerp ? ls3 : instantiator,
1618 subtable, Qunbound);
1619
1620 if (UNBOUNDP (instance))
1621 {
1622 Lisp_Object locative =
1623 noseeum_cons (Qnil,
1624 noseeum_cons (pointerp ? ls3 : instantiator,
1625 subtable));
1626 int speccount = specpdl_depth ();
1627
1628 /* make sure we cache the failures, too.
1629 Use an unwind-protect to catch such errors.
1630 If we fail, the unwind-protect records nil in
1631 the hash table. If we succeed, we change the
1632 car of the locative to the resulting instance,
1633 which gets recorded instead. */
1634 record_unwind_protect (image_instantiate_cache_result,
1635 locative);
1636 instance = instantiate_image_instantiator (device,
1637 instantiator,
1638 pointer_fg, pointer_bg,
1639 dest_mask);
1640 Fsetcar (locative, instance);
1641 unbind_to (speccount, Qnil);
1642 }
1643 else
1644 free_list (ls3);
1645
1646 if (NILP (instance))
1647 signal_simple_error ("Can't instantiate image (probably cached)",
1648 instantiator);
1649 return instance;
1650 }
1651
1652 abort ();
1653 return Qnil; /* not reached */
1654 }
1655
1656 /* Validate an image instantiator. */
1657
1658 static void
1659 image_validate (Lisp_Object instantiator)
1660 {
1661 if (IMAGE_INSTANCEP (instantiator) || STRINGP (instantiator))
1662 return;
1663 else if (VECTORP (instantiator))
1664 {
1665 Lisp_Object *elt = vector_data (XVECTOR (instantiator));
1666 int instantiator_len = XVECTOR (instantiator)->size;
1667 struct image_instantiator_methods *meths;
1668 Lisp_Object already_seen = Qnil;
1669 struct gcpro gcpro1;
1670 int i;
1671
1672 if (instantiator_len < 1)
1673 signal_simple_error ("Vector length must be at least 1",
1674 instantiator);
1675
1676 meths = decode_image_instantiator_format (elt[0], ERROR_ME);
1677 if (!(instantiator_len & 1))
1678 signal_simple_error
1679 ("Must have alternating keyword/value pairs", instantiator);
1680
1681 GCPRO1 (already_seen);
1682
1683 for (i = 1; i < instantiator_len; i += 2)
1684 {
1685 Lisp_Object keyword = elt[i];
1686 Lisp_Object value = elt[i+1];
1687 int j;
1688
1689 CHECK_SYMBOL (keyword);
1690 if (!SYMBOL_IS_KEYWORD (keyword))
1691 signal_simple_error ("Symbol must begin with a colon", keyword);
1692
1693 for (j = 0; j < Dynarr_length (meths->keywords); j++)
1694 if (EQ (keyword, Dynarr_at (meths->keywords, j).keyword))
1695 break;
1696
1697 if (j == Dynarr_length (meths->keywords))
1698 signal_simple_error ("Unrecognized keyword", keyword);
1699
1700 if (!Dynarr_at (meths->keywords, j).multiple_p)
1701 {
1702 if (!NILP (memq_no_quit (keyword, already_seen)))
1703 signal_simple_error
1704 ("Keyword may not appear more than once", keyword);
1705 already_seen = Fcons (keyword, already_seen);
1706 }
1707
1708 (Dynarr_at (meths->keywords, j).validate) (value);
1709 }
1710
1711 UNGCPRO;
1712
1713 MAYBE_IIFORMAT_METH (meths, validate, (instantiator));
1714 }
1715 else
1716 signal_simple_error ("Must be string or vector", instantiator);
1717 }
1718
1719 static void
1720 image_after_change (Lisp_Object specifier, Lisp_Object locale)
1721 {
1722 Lisp_Object attachee =
1723 IMAGE_SPECIFIER_ATTACHEE (XIMAGE_SPECIFIER (specifier));
1724 Lisp_Object property =
1725 IMAGE_SPECIFIER_ATTACHEE_PROPERTY (XIMAGE_SPECIFIER (specifier));
1726 if (FACEP (attachee))
1727 face_property_was_changed (attachee, property, locale);
1728 else if (GLYPHP (attachee))
1729 glyph_property_was_changed (attachee, property, locale);
1730 }
1731
1732 void
1733 set_image_attached_to (Lisp_Object obj, Lisp_Object face_or_glyph,
1734 Lisp_Object property)
1735 {
1736 struct Lisp_Specifier *image = XIMAGE_SPECIFIER (obj);
1737
1738 IMAGE_SPECIFIER_ATTACHEE (image) = face_or_glyph;
1739 IMAGE_SPECIFIER_ATTACHEE_PROPERTY (image) = property;
1740 }
1741
1742 static Lisp_Object
1743 image_going_to_add (Lisp_Object specifier, Lisp_Object locale,
1744 Lisp_Object tag_set, Lisp_Object instantiator)
1745 {
1746 Lisp_Object possible_console_types = Qnil;
1747 Lisp_Object rest;
1748 Lisp_Object retlist = Qnil;
1749 struct gcpro gcpro1, gcpro2;
1750
1751 LIST_LOOP (rest, Vconsole_type_list)
1752 {
1753 Lisp_Object contype = XCAR (rest);
1754 if (!NILP (memq_no_quit (contype, tag_set)))
1755 possible_console_types = Fcons (contype, possible_console_types);
1756 }
1757
1758 if (XINT (Flength (possible_console_types)) > 1)
1759 /* two conflicting console types specified */
1760 return Qnil;
1761
1762 if (NILP (possible_console_types))
1763 possible_console_types = Vconsole_type_list;
1764
1765 GCPRO2 (retlist, possible_console_types);
1766
1767 LIST_LOOP (rest, possible_console_types)
1768 {
1769 Lisp_Object newinst;
1770 Lisp_Object contype = XCAR (rest);
1771
1772 newinst = call_with_suspended_errors (normalize_image_instantiator,
1773 Qnil, Qimage, ERROR_ME_NOT,
1774 3, instantiator, contype,
1775 make_int
1776 (XIMAGE_SPECIFIER_ALLOWED
1777 (specifier)));
1778 if (!NILP (newinst))
1779 {
1780 Lisp_Object newtag;
1781 if (NILP (memq_no_quit (contype, tag_set)))
1782 newtag = Fcons (contype, tag_set);
1783 else
1784 newtag = tag_set;
1785 retlist = Fcons (Fcons (newtag, newinst), retlist);
1786 }
1787 }
1788
1789 UNGCPRO;
1790
1791 return retlist;
1792 }
1793
1794 DEFUN ("image-specifier-p", Fimage_specifier_p, Simage_specifier_p, 1, 1, 0 /*
1795 Return non-nil if OBJECT is an image specifier.
1796
1797 An image specifier is used for images (pixmaps and the like). It is used
1798 to describe the actual image in a glyph. It is instanced as an image-
1799 instance.
1800
1801 Image instantiators come in many formats: `xbm', `xpm', `gif', `jpeg',
1802 etc. This describes the format of the data describing the image. The
1803 resulting image instances also come in many types -- `mono-pixmap',
1804 `color-pixmap', `text', `pointer', etc. This refers to the behavior of
1805 the image and the sorts of places it can appear. (For example, a
1806 color-pixmap image has fixed colors specified for it, while a
1807 mono-pixmap image comes in two unspecified shades \"foreground\" and
1808 \"background\" that are determined from the face of the glyph or
1809 surrounding text; a text image appears as a string of text and has an
1810 unspecified foreground, background, and font; a pointer image behaves
1811 like a mono-pixmap image but can only be used as a mouse pointer
1812 \[mono-pixmap images cannot be used as mouse pointers]; etc.) It is
1813 important to keep the distinction between image instantiator format and
1814 image instance type in mind. Typically, a given image instantiator
1815 format can result in many different image instance types (for example,
1816 `xpm' can be instanced as `color-pixmap', `mono-pixmap', or `pointer';
1817 whereas `cursor-font' can be instanced only as `pointer'), and a
1818 particular image instance type can be generated by many different
1819 image instantiator formats (e.g. `color-pixmap' can be generated by `xpm',
1820 `gif', `jpeg', etc.).
1821
1822 See `make-image-instance' for a more detailed discussion of image
1823 instance types.
1824
1825 An image instantiator should be a string or a vector of the form
1826
1827 [FORMAT :KEYWORD VALUE ...]
1828
1829 i.e. a format symbol followed by zero or more alternating keyword-value
1830 pairs. FORMAT should be one of
1831
1832 'nothing
1833 (Don't display anything; no keywords are valid for this.
1834 Can only be instanced as `nothing'.)
1835 'string
1836 (Display this image as a text string. Can only be instanced
1837 as `text', although support for instancing as `mono-pixmap'
1838 should be added.)
1839 'formatted-string
1840 (Display this image as a text string, with replaceable fields;
1841 not currently implemented.)
1842 'xbm
1843 (An X bitmap; only if X support was compiled into this XEmacs.
1844 Can be instanced as `mono-pixmap', `color-pixmap', or `pointer'.)
1845 'xpm
1846 (An XPM pixmap; only if XPM support was compiled into this XEmacs.
1847 Can be instanced as `color-pixmap', `mono-pixmap', or `pointer'.)
1848 'xface
1849 (An X-Face bitmap, used to encode people's faces in e-mail messages;
1850 only if X-Face support was compiled into this XEmacs. Can be
1851 instanced as `mono-pixmap', `color-pixmap', or `pointer'.)
1852 'gif
1853 (A GIF87 or GIF89 image; only if GIF support was compiled into this
1854 XEmacs. Can be instanced as `color-pixmap'.)
1855 'jpeg
1856 (A JPEG image; only if JPEG support was compiled into this XEmacs.
1857 Can be instanced as `color-pixmap'.)
1858 'png
1859 (A PNG/GIF24 image; only if PNG support was compiled into this XEmacs.
1860 Can be instanced as `color-pixmap'.)
1861 'tiff
1862 (A TIFF image; not currently implemented.)
1863 'cursor-font
1864 (One of the standard cursor-font names, such as \"watch\" or
1865 \"right_ptr\" under X. Under X, this is, more specifically, any
1866 of the standard cursor names from appendix B of the Xlib manual
1867 [also known as the file <X11/cursorfont.h>] minus the XC_ prefix.
1868 On other window systems, the valid names will be specific to the
1869 type of window system. Can only be instanced as `pointer'.)
1870 'font
1871 (A glyph from a font; i.e. the name of a font, and glyph index into it
1872 of the form \"FONT fontname index [[mask-font] mask-index]\".
1873 Currently can only be instanced as `pointer', although this should
1874 probably be fixed.)
1875 'subwindow
1876 (An embedded X window; not currently implemented.)
1877 'autodetect
1878 (XEmacs tries to guess what format the data is in. If X support
1879 exists, the data string will be checked to see if it names a filename.
1880 If so, and this filename contains XBM or XPM data, the appropriate
1881 sort of pixmap or pointer will be created. [This includes picking up
1882 any specified hotspot or associated mask file.] Otherwise, if `pointer'
1883 is one of the allowable image-instance types and the string names a
1884 valid cursor-font name, the image will be created as a pointer.
1885 Otherwise, the image will be displayed as text. If no X support
1886 exists, the image will always be displayed as text.)
1887 'inherit
1888 Inherit from the background-pixmap property of a face.
1889
1890 The valid keywords are:
1891
1892 :data
1893 (Inline data. For most formats above, this should be a string. For
1894 XBM images, this should be a list of three elements: width, height, and
1895 a string of bit data. This keyword is not valid for instantiator
1896 formats `nothing' and `inherit'.)
1897 :file
1898 (Data is contained in a file. The value is the name of this file.
1899 If both :data and :file are specified, the image is created from
1900 what is specified in :data and the string in :file becomes the
1901 value of the `image-instance-file-name' function when applied to
1902 the resulting image-instance. This keyword is not valid for
1903 instantiator formats `nothing', `string', `formatted-string',
1904 `cursor-font', `font', `autodetect', and `inherit'.)
1905 :foreground
1906 :background
1907 (For `xbm', `xface', `cursor-font', and `font'. These keywords
1908 allow you to explicitly specify foreground and background colors.
1909 The argument should be anything acceptable to `make-color-instance'.
1910 This will cause what would be a `mono-pixmap' to instead be colorized
1911 as a two-color color-pixmap, and specifies the foreground and/or
1912 background colors for a pointer instead of black and white.)
1913 :mask-data
1914 (For `xbm' and `xface'. This specifies a mask to be used with the
1915 bitmap. The format is a list of width, height, and bits, like for
1916 :data.)
1917 :mask-file
1918 (For `xbm' and `xface'. This specifies a file containing the mask data.
1919 If neither a mask file nor inline mask data is given for an XBM image,
1920 and the XBM image comes from a file, XEmacs will look for a mask file
1921 with the same name as the image file but with \"Mask\" or \"msk\"
1922 appended. For example, if you specify the XBM file \"left_ptr\"
1923 [usually located in \"/usr/include/X11/bitmaps\"], the associated
1924 mask file \"left_ptrmsk\" will automatically be picked up.)
1925 :hotspot-x
1926 :hotspot-y
1927 (For `xbm' and `xface'. These keywords specify a hotspot if the image
1928 is instantiated as a `pointer'. Note that if the XBM image file
1929 specifies a hotspot, it will automatically be picked up if no
1930 explicit hotspot is given.)
1931 :color-symbols
1932 (Only for `xpm'. This specifies an alist that maps strings
1933 that specify symbolic color names to the actual color to be used
1934 for that symbolic color (in the form of a string or a color-specifier
1935 object). If this is not specified, the contents of `xpm-color-symbols'
1936 are used to generate the alist.)
1937 :face
1938 (Only for `inherit'. This specifies the face to inherit from.)
1939
1940 If instead of a vector, the instantiator is a string, it will be
1941 converted into a vector by looking it up according to the specs in the
1942 `console-type-image-conversion-list' (q.v.) for the console type of
1943 the domain (usually a window; sometimes a frame or device) over which
1944 the image is being instantiated.
1945
1946 If the instantiator specifies data from a file, the data will be read
1947 in at the time that the instantiator is added to the image (which may
1948 be well before when the image is actually displayed), and the
1949 instantiator will be converted into one of the inline-data forms, with
1950 the filename retained using a :file keyword. This implies that the
1951 file must exist when the instantiator is added to the image, but does
1952 not need to exist at any other time (e.g. it may safely be a temporary
1953 file).
1954 */ )
1955 (object)
1956 Lisp_Object object;
1957 {
1958 return (IMAGE_SPECIFIERP (object) ? Qt : Qnil);
1959 }
1960
1961
1962 /****************************************************************************
1963 * Glyph Object *
1964 ****************************************************************************/
1965
1966 static Lisp_Object mark_glyph (Lisp_Object, void (*) (Lisp_Object));
1967 static void print_glyph (Lisp_Object, Lisp_Object, int);
1968 static int glyph_equal (Lisp_Object, Lisp_Object, int depth);
1969 static unsigned long glyph_hash (Lisp_Object obj, int depth);
1970 static Lisp_Object glyph_getprop (Lisp_Object obj, Lisp_Object prop);
1971 static int glyph_putprop (Lisp_Object obj, Lisp_Object prop,
1972 Lisp_Object value);
1973 static int glyph_remprop (Lisp_Object obj, Lisp_Object prop);
1974 static Lisp_Object glyph_plist (Lisp_Object obj);
1975 DEFINE_LRECORD_IMPLEMENTATION_WITH_PROPS ("glyph", glyph,
1976 mark_glyph, print_glyph, 0,
1977 glyph_equal, glyph_hash,
1978 glyph_getprop, glyph_putprop,
1979 glyph_remprop, glyph_plist,
1980 struct Lisp_Glyph);
1981
1982 static Lisp_Object
1983 mark_glyph (Lisp_Object obj, void (*markobj) (Lisp_Object))
1984 {
1985 struct Lisp_Glyph *glyph = XGLYPH (obj);
1986
1987 ((markobj) (glyph->image));
1988 ((markobj) (glyph->contrib_p));
1989 ((markobj) (glyph->baseline));
1990 ((markobj) (glyph->face));
1991
1992 return (glyph->plist);
1993 }
1994
1995 static void
1996 print_glyph (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1997 {
1998 struct Lisp_Glyph *glyph = XGLYPH (obj);
1999 char buf[20];
2000
2001 if (print_readably)
2002 error ("printing unreadable object #<glyph 0x%x>", glyph->header.uid);
2003
2004 write_c_string ("#<glyph (", printcharfun);
2005 print_internal (Fglyph_type (obj), printcharfun, 0);
2006 write_c_string (") ", printcharfun);
2007 print_internal (glyph->image, printcharfun, 1);
2008 sprintf (buf, "0x%x>", glyph->header.uid);
2009 write_c_string (buf, printcharfun);
2010 }
2011
2012 /* Glyphs are equal if all of their display attributes are equal. We
2013 don't compare names or doc-strings, because that would make equal
2014 be eq.
2015
2016 This isn't concerned with "unspecified" attributes, that's what
2017 #'glyph-differs-from-default-p is for. */
2018 static int
2019 glyph_equal (Lisp_Object o1, Lisp_Object o2, int depth)
2020 {
2021 struct Lisp_Glyph *g1 = XGLYPH (o1);
2022 struct Lisp_Glyph *g2 = XGLYPH (o2);
2023
2024 depth++;
2025
2026 if (!internal_equal (g1->image, g2->image, depth) ||
2027 !internal_equal (g1->contrib_p, g2->contrib_p, depth) ||
2028 !internal_equal (g1->baseline, g2->baseline, depth) ||
2029 !internal_equal (g1->face, g2->face, depth) ||
2030 plists_differ (g1->plist, g2->plist, 0, 0, depth + 1))
2031 return 0;
2032
2033 return 1;
2034 }
2035
2036 static unsigned long
2037 glyph_hash (Lisp_Object obj, int depth)
2038 {
2039 struct Lisp_Glyph *g = XGLYPH (obj);
2040
2041 depth++;
2042
2043 /* No need to hash all of the elements; that would take too long.
2044 Just hash the most common ones. */
2045 return HASH2 (internal_hash (g->image, depth),
2046 internal_hash (g->face, depth));
2047 }
2048
2049 static Lisp_Object
2050 glyph_getprop (Lisp_Object obj, Lisp_Object prop)
2051 {
2052 struct Lisp_Glyph *g = XGLYPH (obj);
2053
2054 #define FROB(propprop) \
2055 do { \
2056 if (EQ (prop, Q##propprop)) \
2057 { \
2058 return g->propprop; \
2059 } \
2060 } while (0)
2061
2062 FROB (image);
2063 FROB (contrib_p);
2064 FROB (baseline);
2065 FROB (face);
2066
2067 #undef FROB
2068
2069 return external_plist_get (&g->plist, prop, 0, ERROR_ME);
2070 }
2071
2072 static int
2073 glyph_putprop (Lisp_Object obj, Lisp_Object prop, Lisp_Object value)
2074 {
2075 struct Lisp_Glyph *g = XGLYPH (obj);
2076
2077 #define FROB(propprop) \
2078 do { \
2079 if (EQ (prop, Q##propprop)) \
2080 return 0; \
2081 } while (0)
2082
2083 FROB (image);
2084 FROB (contrib_p);
2085 FROB (baseline);
2086
2087 #undef FROB
2088
2089 if (EQ (prop, Qface))
2090 {
2091 value = Fget_face (value);
2092 g->face = value;
2093 return 1;
2094 }
2095
2096 external_plist_put (&g->plist, prop, value, 0, ERROR_ME);
2097 return 1;
2098 }
2099
2100 static int
2101 glyph_remprop (Lisp_Object obj, Lisp_Object prop)
2102 {
2103 struct Lisp_Glyph *g = XGLYPH (obj);
2104
2105 #define FROB(propprop) \
2106 do { \
2107 if (EQ (prop, Q##propprop)) \
2108 return -1; \
2109 } while (0)
2110
2111 FROB (image);
2112 FROB (contrib_p);
2113 FROB (baseline);
2114
2115 if (EQ (prop, Qface))
2116 {
2117 g->face = Qnil;
2118 return 1;
2119 }
2120
2121 #undef FROB
2122 return external_remprop (&g->plist, prop, 0, ERROR_ME);
2123 }
2124
2125 static Lisp_Object
2126 glyph_plist (Lisp_Object obj)
2127 {
2128 struct Lisp_Glyph *g = XGLYPH (obj);
2129 Lisp_Object result = Qnil;
2130
2131 #define FROB(propprop) \
2132 do { \
2133 /* backwards order; we reverse it below */ \
2134 result = Fcons (g->propprop, Fcons (Q##propprop, result)); \
2135 } while (0)
2136
2137 FROB (image);
2138 FROB (contrib_p);
2139 FROB (baseline);
2140 FROB (face);
2141
2142 #undef FROB
2143 return nconc2 (Fnreverse (result), g->plist);
2144 }
2145
2146 Lisp_Object
2147 allocate_glyph (enum glyph_type type,
2148 void (*after_change) (Lisp_Object glyph, Lisp_Object property,
2149 Lisp_Object locale))
2150 {
2151 Lisp_Object obj = Qnil;
2152 struct Lisp_Glyph *g =
2153 alloc_lcrecord (sizeof (struct Lisp_Glyph), lrecord_glyph);
2154
2155 g->type = type;
2156 g->image = Fmake_specifier (Qimage);
2157 switch (g->type)
2158 {
2159 case GLYPH_BUFFER:
2160 XIMAGE_SPECIFIER_ALLOWED (g->image) =
2161 IMAGE_NOTHING_MASK | IMAGE_TEXT_MASK | IMAGE_MONO_PIXMAP_MASK |
2162 IMAGE_COLOR_PIXMAP_MASK | IMAGE_SUBWINDOW_MASK;
2163 break;
2164 case GLYPH_POINTER:
2165 XIMAGE_SPECIFIER_ALLOWED (g->image) =
2166 IMAGE_NOTHING_MASK | IMAGE_POINTER_MASK;
2167 break;
2168 case GLYPH_ICON:
2169 XIMAGE_SPECIFIER_ALLOWED (g->image) =
2170 IMAGE_NOTHING_MASK | IMAGE_MONO_PIXMAP_MASK | IMAGE_COLOR_PIXMAP_MASK;
2171 break;
2172 default:
2173 abort ();
2174 }
2175
2176 set_specifier_fallback (g->image, list1 (Fcons (Qnil, Vthe_nothing_vector)));
2177 g->contrib_p = Fmake_specifier (Qboolean);
2178 set_specifier_fallback (g->contrib_p, list1 (Fcons (Qnil, Qt)));
2179 /* #### should have a specifier for the following */
2180 g->baseline = Fmake_specifier (Qgeneric);
2181 set_specifier_fallback (g->baseline, list1 (Fcons (Qnil, Qnil)));
2182 g->face = Qnil;
2183 g->plist = Qnil;
2184 g->after_change = after_change;
2185 XSETGLYPH (obj, g);
2186
2187 set_image_attached_to (g->image, obj, Qimage);
2188
2189 return obj;
2190 }
2191
2192 static enum glyph_type
2193 decode_glyph_type (Lisp_Object type, Error_behavior errb)
2194 {
2195 if (NILP (type))
2196 return GLYPH_BUFFER;
2197
2198 if (ERRB_EQ (errb, ERROR_ME))
2199 CHECK_SYMBOL (type);
2200
2201 if (EQ (type, Qbuffer))
2202 return GLYPH_BUFFER;
2203 if (EQ (type, Qpointer))
2204 return GLYPH_POINTER;
2205 if (EQ (type, Qicon))
2206 return GLYPH_ICON;
2207
2208 maybe_signal_simple_error ("Invalid glyph type", type, Qimage, errb);
2209 return GLYPH_UNKNOWN;
2210 }
2211
2212 static int
2213 valid_glyph_type_p (Lisp_Object type)
2214 {
2215 if (!NILP (memq_no_quit (type, Vglyph_type_list)))
2216 return 1;
2217 return 0;
2218 }
2219
2220 DEFUN ("valid-glyph-type-p", Fvalid_glyph_type_p,
2221 Svalid_glyph_type_p, 1, 1, 0 /*
2222 Given a GLYPH-TYPE, return non-nil if it is valid.
2223 Valid types are `buffer', `pointer', and `icon'.
2224 */ )
2225 (glyph_type)
2226 Lisp_Object glyph_type;
2227 {
2228 if (valid_glyph_type_p (glyph_type))
2229 return Qt;
2230 else
2231 return Qnil;
2232 }
2233
2234 DEFUN ("glyph-type-list", Fglyph_type_list,
2235 Sglyph_type_list,
2236 0, 0, 0 /*
2237 Return a list of valid glyph types.
2238 */ )
2239 ()
2240 {
2241 return Fcopy_sequence (Vglyph_type_list);
2242 }
2243
2244 DEFUN ("make-glyph-internal", Fmake_glyph_internal, Smake_glyph_internal,
2245 0, 1, 0 /*
2246 Create a new, uninitialized glyph.
2247
2248 TYPE specifies the type of the glyph; this should be one of `buffer',
2249 `pointer', or `icon', and defaults to `buffer'. The type of the glyph
2250 specifies in which contexts the glyph can be used, and controls the
2251 allowable image types into which the glyph's image can be
2252 instantiated.
2253
2254 `buffer' glyphs can be used as the begin-glyph or end-glyph of an
2255 extent, in the modeline, and in the toolbar. Their image can be
2256 instantiated as `nothing', `mono-pixmap', `color-pixmap', `text',
2257 and `subwindow'.
2258
2259 `pointer' glyphs can be used to specify the mouse pointer. Their
2260 image can be instantiated as `pointer'.
2261
2262 `icon' glyphs can be used to specify the icon used when a frame is
2263 iconified. Their image can be instantiated as `mono-pixmap' and
2264 `color-pixmap'.
2265 */ )
2266 (type)
2267 Lisp_Object type;
2268 {
2269 enum glyph_type typeval = decode_glyph_type (type, ERROR_ME);
2270 return allocate_glyph (typeval, 0);
2271 }
2272
2273 DEFUN ("glyphp", Fglyphp, Sglyphp, 1, 1, 0 /*
2274 Return non-nil if OBJECT is a glyph.
2275
2276 A glyph is an object used for pixmaps and the like. It is used
2277 in begin-glyphs and end-glyphs attached to extents, in marginal and textual
2278 annotations, in overlay arrows (overlay-arrow-* variables), in toolbar
2279 buttons, and the like. Its image is described using an image specifier --
2280 see `image-specifier-p'.
2281 */ )
2282 (object)
2283 Lisp_Object object;
2284 {
2285 return GLYPHP (object) ? Qt : Qnil;
2286 }
2287
2288 DEFUN ("glyph-type", Fglyph_type, Sglyph_type,
2289 1, 1, 0 /*
2290 Return the type of the given glyph.
2291 The return value will be one of 'buffer, 'pointer, or 'icon.
2292 */ )
2293 (glyph)
2294 Lisp_Object glyph;
2295 {
2296 CHECK_GLYPH (glyph);
2297 switch (XGLYPH_TYPE (glyph))
2298 {
2299 case GLYPH_BUFFER:
2300 return Qbuffer;
2301 case GLYPH_POINTER:
2302 return Qpointer;
2303 case GLYPH_ICON:
2304 return Qicon;
2305 default:
2306 abort ();
2307 }
2308
2309 return Qnil; /* not reached */
2310 }
2311
2312 /*****************************************************************************
2313 glyph_width
2314
2315 Return the width of the given GLYPH on the given WINDOW. If the
2316 instance is a string then the width is calculated using the font of
2317 the given FACE, unless a face is defined by the glyph itself.
2318 ****************************************************************************/
2319 unsigned short
2320 glyph_width (Lisp_Object glyph, Lisp_Object frame_face,
2321 face_index window_findex, Lisp_Object window)
2322 {
2323 Lisp_Object instance;
2324 Lisp_Object frame = XWINDOW (window)->frame;
2325
2326 /* #### We somehow need to distinguish between the user causing this
2327 error condition and a bug causing it. */
2328 if (!GLYPHP (glyph))
2329 return 0;
2330 else
2331 instance = glyph_image_instance (glyph, window, ERROR_ME_NOT, 1);
2332
2333 if (!IMAGE_INSTANCEP (instance))
2334 return 0;
2335
2336 switch (XIMAGE_INSTANCE_TYPE (instance))
2337 {
2338 case IMAGE_TEXT:
2339 {
2340 Lisp_Object str = XIMAGE_INSTANCE_TEXT_STRING (instance);
2341 Lisp_Object private_face = XGLYPH_FACE(glyph);
2342
2343 if (!NILP (private_face))
2344 return (redisplay_frame_text_width_string (XFRAME (frame),
2345 private_face,
2346 0, str, 0, -1));
2347 else
2348 if (!NILP (frame_face))
2349 return (redisplay_frame_text_width_string (XFRAME (frame),
2350 frame_face,
2351 0, str, 0, -1));
2352 else
2353 return (redisplay_text_width_string (XWINDOW (window),
2354 window_findex,
2355 0, str, 0, -1));
2356 }
2357
2358 case IMAGE_MONO_PIXMAP:
2359 case IMAGE_COLOR_PIXMAP:
2360 case IMAGE_POINTER:
2361 return XIMAGE_INSTANCE_PIXMAP_WIDTH (instance);
2362
2363 case IMAGE_NOTHING:
2364 return 0;
2365
2366 case IMAGE_SUBWINDOW:
2367 /* #### implement me */
2368 return 0;
2369
2370 default:
2371 abort ();
2372 return 0;
2373 }
2374 }
2375
2376 DEFUN ("glyph-width", Fglyph_width, Sglyph_width, 1, 2, 0 /*
2377 Return the width of GLYPH on WINDOW.
2378 This may not be exact as it does not take into account all of the context
2379 that redisplay will.
2380 */ )
2381 (glyph, window)
2382 Lisp_Object glyph, window;
2383 {
2384 XSETWINDOW (window, decode_window (window));
2385 CHECK_GLYPH (glyph);
2386
2387 return (make_int (glyph_width (glyph, Qnil, DEFAULT_INDEX, window)));
2388 }
2389
2390 #define RETURN_ASCENT 0
2391 #define RETURN_DESCENT 1
2392 #define RETURN_HEIGHT 2
2393
2394 Lisp_Object
2395 glyph_image_instance (Lisp_Object glyph, Lisp_Object domain,
2396 Error_behavior errb, int no_quit)
2397 {
2398 Lisp_Object specifier = GLYPH_IMAGE (XGLYPH (glyph));
2399
2400 /* This can never return Qunbound. All glyphs have 'nothing as
2401 a fallback. */
2402 return specifier_instance (specifier, Qunbound, domain, errb, no_quit, 0,
2403 Qzero);
2404 }
2405
2406 static unsigned short
2407 glyph_height_internal (Lisp_Object glyph, Lisp_Object frame_face,
2408 face_index window_findex, Lisp_Object window,
2409 int function)
2410 {
2411 Lisp_Object instance;
2412 Lisp_Object frame = XWINDOW (window)->frame;
2413
2414 if (!GLYPHP (glyph))
2415 return 0;
2416 else
2417 instance = glyph_image_instance (glyph, window, ERROR_ME_NOT, 1);
2418
2419 if (!IMAGE_INSTANCEP (instance))
2420 return 0;
2421
2422 switch (XIMAGE_INSTANCE_TYPE (instance))
2423 {
2424 case IMAGE_TEXT:
2425 {
2426 struct font_metric_info fm;
2427 Lisp_Object string = XIMAGE_INSTANCE_TEXT_STRING (instance);
2428 unsigned char charsets[NUM_LEADING_BYTES];
2429 struct face_cachel frame_cachel;
2430 struct face_cachel *cachel;
2431
2432 find_charsets_in_bufbyte_string (charsets,
2433 string_data (XSTRING (string)),
2434 string_length (XSTRING (string)));
2435
2436 if (!NILP (frame_face))
2437 {
2438 reset_face_cachel (&frame_cachel);
2439 update_face_cachel_data (&frame_cachel, frame, frame_face);
2440 cachel = &frame_cachel;
2441 }
2442 else
2443 cachel = WINDOW_FACE_CACHEL (XWINDOW (window), window_findex);
2444 ensure_face_cachel_complete (cachel, window, charsets);
2445
2446 face_cachel_charset_font_metric_info (cachel, charsets, &fm);
2447
2448 if (function == RETURN_ASCENT)
2449 return fm.ascent;
2450 else if (function == RETURN_DESCENT)
2451 return fm.descent;
2452 else if (function == RETURN_HEIGHT)
2453 return fm.ascent + fm.descent;
2454 else
2455 abort ();
2456 return 0;
2457 }
2458
2459 case IMAGE_MONO_PIXMAP:
2460 case IMAGE_COLOR_PIXMAP:
2461 case IMAGE_POINTER:
2462 /* #### Ugh ugh ugh -- temporary crap */
2463 if (function == RETURN_ASCENT || function == RETURN_HEIGHT)
2464 return XIMAGE_INSTANCE_PIXMAP_HEIGHT (instance);
2465 else
2466 return 0;
2467
2468 case IMAGE_NOTHING:
2469 return 0;
2470
2471 case IMAGE_SUBWINDOW:
2472 /* #### implement me */
2473 return 0;
2474
2475 default:
2476 abort ();
2477 return 0;
2478 }
2479 }
2480
2481 unsigned short
2482 glyph_ascent (Lisp_Object glyph, Lisp_Object frame_face,
2483 face_index window_findex, Lisp_Object window)
2484 {
2485 return glyph_height_internal (glyph, frame_face, window_findex, window,
2486 RETURN_ASCENT);
2487 }
2488
2489 unsigned short
2490 glyph_descent (Lisp_Object glyph, Lisp_Object frame_face,
2491 face_index window_findex, Lisp_Object window)
2492 {
2493 return glyph_height_internal (glyph, frame_face, window_findex, window,
2494 RETURN_DESCENT);
2495 }
2496
2497 /* strictly a convenience function. */
2498 unsigned short
2499 glyph_height (Lisp_Object glyph, Lisp_Object frame_face,
2500 face_index window_findex, Lisp_Object window)
2501 {
2502 return glyph_height_internal (glyph, frame_face, window_findex, window,
2503 RETURN_HEIGHT);
2504 }
2505
2506 DEFUN ("glyph-ascent", Fglyph_ascent, Sglyph_ascent, 1, 2, 0 /*
2507 Return the ascent value of GLYPH on WINDOW.
2508 This may not be exact as it does not take into account all of the context
2509 that redisplay will.
2510 */ )
2511 (glyph, window)
2512 Lisp_Object glyph, window;
2513 {
2514 XSETWINDOW (window, decode_window (window));
2515 CHECK_GLYPH (glyph);
2516
2517 return (make_int (glyph_ascent (glyph, Qnil, DEFAULT_INDEX, window)));
2518 }
2519
2520 DEFUN ("glyph-descent", Fglyph_descent, Sglyph_descent, 1, 2, 0 /*
2521 Return the descent value of GLYPH on WINDOW.
2522 This may not be exact as it does not take into account all of the context
2523 that redisplay will.
2524 */ )
2525 (glyph, window)
2526 Lisp_Object glyph, window;
2527 {
2528 XSETWINDOW (window, decode_window (window));
2529 CHECK_GLYPH (glyph);
2530
2531 return (make_int (glyph_descent (glyph, Qnil, DEFAULT_INDEX, window)));
2532 }
2533
2534 /* This is redundant but I bet a lot of people expect it to exist. */
2535 DEFUN ("glyph-height", Fglyph_height, Sglyph_height, 1, 2, 0 /*
2536 Return the height of GLYPH on WINDOW.
2537 This may not be exact as it does not take into account all of the context
2538 that redisplay will.
2539 */ )
2540 (glyph, window)
2541 Lisp_Object glyph, window;
2542 {
2543 XSETWINDOW (window, decode_window (window));
2544 CHECK_GLYPH (glyph);
2545
2546 return (make_int (glyph_height (glyph, Qnil, DEFAULT_INDEX, window)));
2547 }
2548
2549 #undef RETURN_ASCENT
2550 #undef RETURN_DESCENT
2551 #undef RETURN_HEIGHT
2552
2553 /* #### do we need to cache this info to speed things up? */
2554
2555 Lisp_Object
2556 glyph_baseline (Lisp_Object glyph, Lisp_Object domain)
2557 {
2558 if (!GLYPHP (glyph))
2559 return Qnil;
2560 else
2561 {
2562 Lisp_Object retval =
2563 specifier_instance_no_quit (GLYPH_BASELINE (XGLYPH (glyph)),
2564 /* #### look into ERROR_ME_NOT */
2565 Qunbound, domain, ERROR_ME_NOT,
2566 0, Qzero);
2567 if (!NILP (retval) && !INTP (retval))
2568 retval = Qnil;
2569 else if (INTP (retval))
2570 {
2571 if (XINT (retval) < 0)
2572 retval = Qzero;
2573 if (XINT (retval) > 100)
2574 retval = make_int (100);
2575 }
2576 return retval;
2577 }
2578 }
2579
2580 Lisp_Object
2581 glyph_face (Lisp_Object glyph, Lisp_Object domain)
2582 {
2583 /* #### Domain parameter not currently used but it will be */
2584 if (!GLYPHP (glyph))
2585 return Qnil;
2586 else
2587 return GLYPH_FACE (XGLYPH (glyph));
2588 }
2589
2590 int
2591 glyph_contrib_p (Lisp_Object glyph, Lisp_Object domain)
2592 {
2593 if (!GLYPHP (glyph))
2594 return 0;
2595 else
2596 return (!NILP (specifier_instance_no_quit
2597 (GLYPH_CONTRIB_P (XGLYPH (glyph)), Qunbound, domain,
2598 /* #### look into ERROR_ME_NOT */
2599 ERROR_ME_NOT, 0, Qzero)));
2600 }
2601
2602 static void
2603 glyph_property_was_changed (Lisp_Object glyph, Lisp_Object property,
2604 Lisp_Object locale)
2605 {
2606 if (XGLYPH (glyph)->after_change)
2607 (XGLYPH (glyph)->after_change) (glyph, property, locale);
2608 }
2609
2610
2611 /*****************************************************************************
2612 * glyph cachel functions *
2613 *****************************************************************************/
2614
2615 /*
2616 #### All of this is 95% copied from face cachels.
2617 Consider consolidating.
2618 #### We need to add a dirty flag to the glyphs.
2619 */
2620
2621 void
2622 mark_glyph_cachels (glyph_cachel_dynarr *elements,
2623 void (*markobj) (Lisp_Object))
2624 {
2625 int elt;
2626
2627 if (!elements)
2628 return;
2629
2630 for (elt = 0; elt < Dynarr_length (elements); elt++)
2631 {
2632 struct glyph_cachel *cachel = Dynarr_atp (elements, elt);
2633 ((markobj) (cachel->glyph));
2634 }
2635 }
2636
2637 static void
2638 update_glyph_cachel_data (struct window *w, Lisp_Object glyph,
2639 struct glyph_cachel *cachel)
2640 {
2641 /* #### This should be || !cachel->updated */
2642 if (NILP (cachel->glyph) || !EQ (cachel->glyph, glyph))
2643 {
2644 Lisp_Object window = Qnil;
2645
2646 XSETWINDOW (window, w);
2647 cachel->glyph = glyph;
2648
2649 #define FROB(field) \
2650 do { \
2651 unsigned short new_val = glyph_##field (glyph, Qnil, DEFAULT_INDEX, \
2652 window); \
2653 if (cachel->field != new_val) \
2654 cachel->field = new_val; \
2655 } while (0)
2656
2657 /* #### This could be sped up if we redid things to grab the glyph
2658 instantiation and passed it to the size functions. */
2659 FROB (width);
2660 FROB (ascent);
2661 FROB (descent);
2662 #undef FROB
2663
2664 }
2665
2666 cachel->updated = 1;
2667 }
2668
2669 static void
2670 add_glyph_cachel (struct window *w, Lisp_Object glyph)
2671 {
2672 struct glyph_cachel new_cachel;
2673
2674 memset (&new_cachel, 0, sizeof (struct glyph_cachel));
2675 new_cachel.glyph = Qnil;
2676
2677 update_glyph_cachel_data (w, glyph, &new_cachel);
2678 Dynarr_add (w->glyph_cachels, new_cachel);
2679 }
2680
2681 static glyph_index
2682 get_glyph_cachel_index (struct window *w, Lisp_Object glyph)
2683 {
2684 int elt;
2685
2686 if (noninteractive)
2687 return 0;
2688
2689 for (elt = 0; elt < Dynarr_length (w->glyph_cachels); elt++)
2690 {
2691 struct glyph_cachel *cachel =
2692 Dynarr_atp (w->glyph_cachels, elt);
2693
2694 if (EQ (cachel->glyph, glyph) && !NILP (glyph))
2695 {
2696 if (!cachel->updated)
2697 update_glyph_cachel_data (w, glyph, cachel);
2698 return elt;
2699 }
2700 }
2701
2702 /* If we didn't find the glyph, add it and then return its index. */
2703 add_glyph_cachel (w, glyph);
2704 return elt;
2705 }
2706
2707 void
2708 reset_glyph_cachels (struct window *w)
2709 {
2710 Dynarr_reset (w->glyph_cachels);
2711 get_glyph_cachel_index (w, Vcontinuation_glyph);
2712 get_glyph_cachel_index (w, Vtruncation_glyph);
2713 get_glyph_cachel_index (w, Vhscroll_glyph);
2714 get_glyph_cachel_index (w, Vcontrol_arrow_glyph);
2715 get_glyph_cachel_index (w, Voctal_escape_glyph);
2716 get_glyph_cachel_index (w, Vinvisible_text_glyph);
2717 }
2718
2719 void
2720 mark_glyph_cachels_as_not_updated (struct window *w)
2721 {
2722 int elt;
2723
2724 /* We need to have a dirty flag to tell if the glyph has changed.
2725 We can check to see if each glyph variable is actually a
2726 completely different glyph, though. */
2727 #define FROB(glyph_obj, gindex) \
2728 update_glyph_cachel_data (w, glyph_obj, \
2729 Dynarr_atp (w->glyph_cachels, gindex))
2730
2731 FROB (Vcontinuation_glyph, CONT_GLYPH_INDEX);
2732 FROB (Vtruncation_glyph, TRUN_GLYPH_INDEX);
2733 FROB (Vhscroll_glyph, HSCROLL_GLYPH_INDEX);
2734 FROB (Vcontrol_arrow_glyph, CONTROL_GLYPH_INDEX);
2735 FROB (Voctal_escape_glyph, OCT_ESC_GLYPH_INDEX);
2736 FROB (Vinvisible_text_glyph, INVIS_GLYPH_INDEX);
2737 #undef FROB
2738
2739 for (elt = 0; elt < Dynarr_length (w->glyph_cachels); elt++)
2740 Dynarr_atp (w->glyph_cachels, elt)->updated = 0;
2741 }
2742
2743 #ifdef MEMORY_USAGE_STATS
2744
2745 int
2746 compute_glyph_cachel_usage (glyph_cachel_dynarr *glyph_cachels,
2747 struct overhead_stats *ovstats)
2748 {
2749 int total = 0;
2750
2751 if (glyph_cachels)
2752 total += Dynarr_memory_usage (glyph_cachels, ovstats);
2753
2754 return total;
2755 }
2756
2757 #endif /* MEMORY_USAGE_STATS */
2758
2759
2760 /*****************************************************************************
2761 * display tables *
2762 *****************************************************************************/
2763
2764 /* Get the display table for use currently on window W with face FACE.
2765 Precedence:
2766
2767 -- FACE's display table
2768 -- W's display table (comes from specifier `current-display-table')
2769
2770 Ignore the specified tables if they are not valid;
2771 if no valid table is specified, return 0. */
2772
2773 struct Lisp_Vector *
2774 get_display_table (struct window *w, face_index findex)
2775 {
2776 Lisp_Object tem = Qnil;
2777
2778 tem = WINDOW_FACE_CACHEL_DISPLAY_TABLE (w, findex);
2779 if (VECTORP (tem) && XVECTOR (tem)->size == DISP_TABLE_SIZE)
2780 return XVECTOR (tem);
2781
2782 tem = w->display_table;
2783 if (VECTORP (tem) && XVECTOR (tem)->size == DISP_TABLE_SIZE)
2784 return XVECTOR (tem);
2785
2786 return 0;
2787 }
2788
2789
2790 /*****************************************************************************
2791 * initialization *
2792 *****************************************************************************/
2793
2794 void
2795 syms_of_glyphs (void)
2796 {
2797 /* image instantiators */
2798
2799 defsubr (&Simage_instantiator_format_list);
2800 defsubr (&Svalid_image_instantiator_format_p);
2801 defsubr (&Sset_console_type_image_conversion_list);
2802 defsubr (&Sconsole_type_image_conversion_list);
2803
2804 defkeyword (&Q_file, ":file");
2805 defkeyword (&Q_data, ":data");
2806 defkeyword (&Q_face, ":face");
2807
2808 /* image specifiers */
2809
2810 defsubr (&Simage_specifier_p);
2811 /* Qimage in general.c */
2812
2813 /* image instances */
2814
2815 defsymbol (&Qimage_instancep, "image-instance-p");
2816
2817 defsymbol (&Qnothing_image_instance_p, "nothing-image-instance-p");
2818 defsymbol (&Qtext_image_instance_p, "text-image-instance-p");
2819 defsymbol (&Qmono_pixmap_image_instance_p, "mono-pixmap-image-instance-p");
2820 defsymbol (&Qcolor_pixmap_image_instance_p, "color-pixmap-image-instance-p");
2821 defsymbol (&Qpointer_image_instance_p, "pointer-image-instance-p");
2822 defsymbol (&Qsubwindow_image_instance_p, "subwindow-image-instance-p");
2823
2824 defsubr (&Smake_image_instance);
2825 defsubr (&Simage_instance_p);
2826 defsubr (&Simage_instance_type);
2827 defsubr (&Svalid_image_instance_type_p);
2828 defsubr (&Simage_instance_type_list);
2829 defsubr (&Simage_instance_name);
2830 defsubr (&Simage_instance_string);
2831 defsubr (&Simage_instance_file_name);
2832 defsubr (&Simage_instance_mask_file_name);
2833 defsubr (&Simage_instance_depth);
2834 defsubr (&Simage_instance_height);
2835 defsubr (&Simage_instance_width);
2836 defsubr (&Simage_instance_hotspot_x);
2837 defsubr (&Simage_instance_hotspot_y);
2838 defsubr (&Simage_instance_foreground);
2839 defsubr (&Simage_instance_background);
2840 defsubr (&Scolorize_image_instance);
2841
2842 /* Qnothing defined as part of the "nothing" image-instantiator
2843 type. */
2844 /* Qtext defined in general.c */
2845 defsymbol (&Qmono_pixmap, "mono-pixmap");
2846 defsymbol (&Qcolor_pixmap, "color-pixmap");
2847 /* Qpointer defined in general.c */
2848 defsymbol (&Qsubwindow, "subwindow");
2849
2850 /* glyphs */
2851
2852 defsymbol (&Qglyphp, "glyphp");
2853 defsymbol (&Qcontrib_p, "contrib-p");
2854 defsymbol (&Qbaseline, "baseline");
2855
2856 defsymbol (&Qbuffer_glyph_p, "buffer-glyph-p");
2857 defsymbol (&Qpointer_glyph_p, "pointer-glyph-p");
2858 defsymbol (&Qicon_glyph_p, "icon-glyph-p");
2859
2860 defsymbol (&Qconst_glyph_variable, "const-glyph-variable");
2861
2862 defsubr (&Sglyph_type);
2863 defsubr (&Svalid_glyph_type_p);
2864 defsubr (&Sglyph_type_list);
2865 defsubr (&Sglyphp);
2866 defsubr (&Smake_glyph_internal);
2867 defsubr (&Sglyph_width);
2868 defsubr (&Sglyph_ascent);
2869 defsubr (&Sglyph_descent);
2870 defsubr (&Sglyph_height);
2871
2872 /* Qbuffer defined in general.c. */
2873 /* Qpointer defined above */
2874 defsymbol (&Qicon, "icon");
2875 }
2876
2877 void
2878 specifier_type_create_image (void)
2879 {
2880 /* image specifiers */
2881
2882 INITIALIZE_SPECIFIER_TYPE_WITH_DATA (image, "image", "imagep");
2883
2884 SPECIFIER_HAS_METHOD (image, create);
2885 SPECIFIER_HAS_METHOD (image, mark);
2886 SPECIFIER_HAS_METHOD (image, instantiate);
2887 SPECIFIER_HAS_METHOD (image, validate);
2888 SPECIFIER_HAS_METHOD (image, after_change);
2889 SPECIFIER_HAS_METHOD (image, going_to_add);
2890 }
2891
2892 void
2893 image_instantiator_format_create (void)
2894 {
2895 /* image instantiators */
2896
2897 the_image_instantiator_format_entry_dynarr =
2898 Dynarr_new (struct image_instantiator_format_entry);
2899
2900 Vimage_instantiator_format_list = Qnil;
2901 staticpro (&Vimage_instantiator_format_list);
2902
2903 INITIALIZE_IMAGE_INSTANTIATOR_FORMAT (nothing, "nothing");
2904
2905 IIFORMAT_HAS_METHOD (nothing, possible_dest_types);
2906 IIFORMAT_HAS_METHOD (nothing, instantiate);
2907
2908 INITIALIZE_IMAGE_INSTANTIATOR_FORMAT (inherit, "inherit");
2909
2910 IIFORMAT_HAS_METHOD (inherit, validate);
2911 IIFORMAT_HAS_METHOD (inherit, normalize);
2912 IIFORMAT_HAS_METHOD (inherit, possible_dest_types);
2913 IIFORMAT_HAS_METHOD (inherit, instantiate);
2914
2915 IIFORMAT_VALID_KEYWORD (inherit, Q_face, check_valid_face);
2916
2917 INITIALIZE_IMAGE_INSTANTIATOR_FORMAT (string, "string");
2918
2919 IIFORMAT_HAS_METHOD (string, validate);
2920 IIFORMAT_HAS_METHOD (string, possible_dest_types);
2921 IIFORMAT_HAS_METHOD (string, instantiate);
2922
2923 IIFORMAT_VALID_KEYWORD (string, Q_data, check_valid_string);
2924
2925 INITIALIZE_IMAGE_INSTANTIATOR_FORMAT (formatted_string, "formatted-string");
2926
2927 IIFORMAT_HAS_METHOD (formatted_string, validate);
2928 IIFORMAT_HAS_METHOD (formatted_string, possible_dest_types);
2929 IIFORMAT_HAS_METHOD (formatted_string, instantiate);
2930
2931 IIFORMAT_VALID_KEYWORD (formatted_string, Q_data, check_valid_string);
2932 }
2933
2934 void
2935 vars_of_glyphs (void)
2936 {
2937 Vthe_nothing_vector = vector1 (Qnothing);
2938 staticpro (&Vthe_nothing_vector);
2939
2940 /* image instances */
2941
2942 Vimage_instance_type_list = list6 (Qnothing, Qtext, Qmono_pixmap,
2943 Qcolor_pixmap, Qpointer, Qsubwindow);
2944 staticpro (&Vimage_instance_type_list);
2945
2946 /* glyphs */
2947
2948 Vglyph_type_list = list3 (Qbuffer, Qpointer, Qicon);
2949 staticpro (&Vglyph_type_list);
2950
2951 /* The octal-escape glyph, control-arrow-glyph and
2952 invisible-text-glyph are completely initialized in glyphs.el */
2953
2954 DEFVAR_LISP ("octal-escape-glyph", &Voctal_escape_glyph /*
2955 What to prefix character codes displayed in octal with.
2956 */);
2957 Voctal_escape_glyph = allocate_glyph (GLYPH_BUFFER, redisplay_glyph_changed);
2958
2959 DEFVAR_LISP ("control-arrow-glyph", &Vcontrol_arrow_glyph /*
2960 What to use as an arrow for control characters.
2961 */);
2962 Vcontrol_arrow_glyph = allocate_glyph (GLYPH_BUFFER,
2963 redisplay_glyph_changed);
2964
2965 DEFVAR_LISP ("invisible-text-glyph", &Vinvisible_text_glyph /*
2966 What to use to indicate the presence of invisible text.
2967 This is the glyph that is displayed when an ellipsis is called for
2968 \(see `selective-display-ellipses' and `buffer-invisibility-spec').
2969 Normally this is three dots (\"...\").
2970 */);
2971 Vinvisible_text_glyph = allocate_glyph (GLYPH_BUFFER,
2972 redisplay_glyph_changed);
2973
2974 /* Partially initialized in glyphs.el */
2975 DEFVAR_LISP ("hscroll-glyph", &Vhscroll_glyph /*
2976 What to display at the beginning of horizontally scrolled lines.
2977 */);
2978 Vhscroll_glyph = allocate_glyph (GLYPH_BUFFER, redisplay_glyph_changed);
2979 }
2980
2981 void
2982 specifier_vars_of_glyphs (void)
2983 {
2984 /* display tables */
2985
2986 DEFVAR_SPECIFIER ("current-display-table", &Vcurrent_display_table /*
2987 *The display table currently in use.
2988 This is a specifier; use `set-specifier' to change it.
2989 The display table is a vector created with `make-display-table'.
2990 The 256 elements control how to display each possible text character.
2991 Each value should be a string, a glyph, a vector or nil.
2992 If a value is a vector it must be composed only of strings and glyphs.
2993 nil means display the character in the default fashion.
2994 Faces can have their own, overriding display table.
2995 */ );
2996 Vcurrent_display_table = Fmake_specifier (Qgeneric);
2997 set_specifier_fallback (Vcurrent_display_table,
2998 list1 (Fcons (Qnil, Qnil)));
2999 set_specifier_caching (Vcurrent_display_table,
3000 slot_offset (struct window,
3001 display_table),
3002 some_window_value_changed,
3003 0, 0);
3004 }
3005
3006 void
3007 complex_vars_of_glyphs (void)
3008 {
3009 /* Partially initialized in glyphs-x.c, glyphs.el */
3010 DEFVAR_LISP ("truncation-glyph", &Vtruncation_glyph /*
3011 What to display at the end of truncated lines.
3012 */ );
3013 Vtruncation_glyph = allocate_glyph (GLYPH_BUFFER, redisplay_glyph_changed);
3014
3015 /* Partially initialized in glyphs-x.c, glyphs.el */
3016 DEFVAR_LISP ("continuation-glyph", &Vcontinuation_glyph /*
3017 What to display at the end of wrapped lines.
3018 */ );
3019 Vcontinuation_glyph = allocate_glyph (GLYPH_BUFFER, redisplay_glyph_changed);
3020
3021 /* Partially initialized in glyphs-x.c, glyphs.el */
3022 DEFVAR_LISP ("xemacs-logo", &Vxemacs_logo /*
3023 The glyph used to display the XEmacs logo at startup.
3024 */ );
3025 Vxemacs_logo = allocate_glyph (GLYPH_BUFFER, 0);
3026 }