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