XEmacs 21.2.28 "Hermes".
[chise/xemacs-chise.git.1] / src / objects-x.c
index bc27fef..5ab99bc 100644 (file)
@@ -28,6 +28,7 @@ Boston, MA 02111-1307, USA.  */
 
 #include <config.h>
 #include "lisp.h"
+#include <limits.h>
 
 #include "console-x.h"
 #include "objects-x.h"
@@ -45,11 +46,13 @@ int x_handle_non_fully_specified_fonts;
 
 /* Replacement for XAllocColor() that tries to return the nearest
    available color if the colormap is full.  Original was from FSFmacs,
-   but rewritten by Jareth Hein <jareth@camelot-soft.com> 97/11/25 */
+   but rewritten by Jareth Hein <jareth@camelot-soft.com> 97/11/25
+   Modified by Lee Kindness <lkindness@csl.co.uk> 31/08/99 to handle previous
+   total failure which was due to a read/write colorcell being the nearest
+   match - tries the next nearest...
 
-/* Return value is 1 for normal success, 2 for nearest color success,
-   3 for Non-deallocable sucess, and 0 for absolute failure (shouldn't
-   happen?) */
+   Return value is 1 for normal success, 2 for nearest color success,
+   3 for Non-deallocable sucess. */
 int
 allocate_nearest_color (Display *display, Colormap colormap, Visual *visual,
                        XColor *color_def)
@@ -66,7 +69,7 @@ allocate_nearest_color (Display *display, Colormap colormap, Visual *visual,
        {
          /* We're dealing with a TrueColor/DirectColor visual, so play games
             with the RGB values in the XColor struct. */
-         /* ### JH: I'm not sure how a call to XAllocColor can fail in a
+         /* #### JH: I'm not sure how a call to XAllocColor can fail in a
             TrueColor or DirectColor visual, so I will just reformat the
             request to match the requirements of the visual, and re-issue
             the request.  If this fails for anybody, I wanna know about it
@@ -114,8 +117,8 @@ allocate_nearest_color (Display *display, Colormap colormap, Visual *visual,
            status = 1;
          else
            {
-             int rd, gr, bl;   
-             /* ### JH: I'm punting here, knowing that doing this will at
+             int rd, gr, bl;
+             /* #### JH: I'm punting here, knowing that doing this will at
                 least draw the color correctly.  However, unless we convert
                 all of the functions that allocate colors (graphics
                 libraries, etc) to use this function doing this is very
@@ -140,30 +143,35 @@ allocate_nearest_color (Display *display, Colormap colormap, Visual *visual,
     }
   else
     {
+      XColor *cells = NULL;
+      /* JH: I can't believe there's no way to go backwards from a
+        colormap ID and get its visual and number of entries, but X
+        apparently isn't built that way... */
+      int no_cells = visual->map_entries;
+      status = 0;
+
       if (XAllocColor (display, colormap, color_def) != 0)
        status = 1;
-      else
+      else while( status != 2 )
        {
          /* If we got to this point, the colormap is full, so we're
             going to try and get the next closest color.  The algorithm used
             is a least-squares matching, which is what X uses for closest
             color matching with StaticColor visuals. */
-         XColor *cells;
-         /* JH: I can't believe there's no way to go backwards from a
-            colormap ID and get its visual and number of entries, but X
-            apparently isn't built that way... */
-         int no_cells = visual->map_entries;
          int nearest;
          long nearest_delta, trial_delta;
          int x;
 
-         cells = alloca_array (XColor, no_cells);
+         if( cells == NULL )
+             {
+                 cells = alloca_array (XColor, no_cells);
+                 for (x = 0; x < no_cells; x++)
+                     cells[x].pixel = x;
 
-         for (x = 0; x < no_cells; x++)
-           cells[x].pixel = x;
+                 /* read the current colormap */
+                 XQueryColors (display, colormap, cells, no_cells);
+             }
 
-         /* read the current colormap */
-         XQueryColors (display, colormap, cells, no_cells);
          nearest = 0;
          /* I'm assuming CSE so I'm not going to condense this. */
          nearest_delta = ((((color_def->red >> 8) - (cells[0].red >> 8))
@@ -184,7 +192,10 @@ allocate_nearest_color (Display *display, Colormap colormap, Visual *visual,
                             +
                             (((color_def->blue >> 8) - (cells[x].blue >> 8))
                              * ((color_def->blue >> 8) - (cells[x].blue >> 8))));
-             if (trial_delta < nearest_delta)
+
+             /* less? Ignore cells marked as previously failing */
+             if( (trial_delta < nearest_delta) &&
+                 (cells[x].pixel != ULONG_MAX) )
                {
                  nearest = x;
                  nearest_delta = trial_delta;
@@ -193,12 +204,15 @@ allocate_nearest_color (Display *display, Colormap colormap, Visual *visual,
          color_def->red = cells[nearest].red;
          color_def->green = cells[nearest].green;
          color_def->blue = cells[nearest].blue;
-         if (XAllocColor (display, colormap, color_def) != 0) {
-           status = 2;
-         } else {
-           status = 0; /* JH: how does this happen??? DOES this happen??? */
-           fprintf(stderr,"allocate_nearest_color returned 0!!!\n");
-         }
+         if (XAllocColor (display, colormap, color_def) != 0)
+             status = 2;
+         else
+             /* LSK: Either the colour map has changed since
+              * we read it, or the colour is allocated
+              * read/write... Mark this cmap entry so it's
+              * ignored in the next iteration.
+              */
+             cells[nearest].pixel = ULONG_MAX;
        }
     }
   return status;
@@ -208,35 +222,31 @@ int
 x_parse_nearest_color (struct device *d, XColor *color, Bufbyte *name,
                       Bytecount len, Error_behavior errb)
 {
-  Display *dpy;
-  Screen *xs;
-  Colormap cmap;
-  Visual *visual;
+  Display *dpy   = DEVICE_X_DISPLAY  (d);
+  Colormap cmap  = DEVICE_X_COLORMAP (d);
+  Visual *visual = DEVICE_X_VISUAL   (d);
   int result;
 
-  dpy = DEVICE_X_DISPLAY (d);
-  xs = DefaultScreenOfDisplay (dpy);
-  cmap = DEVICE_X_COLORMAP(d);
-  visual = DEVICE_X_VISUAL (d);
-
   xzero (*color);
   {
     CONST Extbyte *extname;
     Extcount extnamelen;
 
-    GET_CHARPTR_EXT_BINARY_DATA_ALLOCA (name, len, extname, extnamelen);
+    TO_EXTERNAL_FORMAT (DATA, (name, len),
+                       ALLOCA, (extname, extnamelen),
+                       Qbinary);
     result = XParseColor (dpy, cmap, (char *) extname, color);
   }
   if (!result)
     {
-      maybe_signal_simple_error ("unrecognized color", make_string (name, len),
+      maybe_signal_simple_error ("Unrecognized color", make_string (name, len),
                                 Qcolor, errb);
       return 0;
     }
   result = allocate_nearest_color (dpy, cmap, visual, color);
   if (!result)
     {
-      maybe_signal_simple_error ("couldn't allocate color",
+      maybe_signal_simple_error ("Couldn't allocate color",
                                 make_string (name, len), Qcolor, errb);
       return 0;
     }
@@ -245,7 +255,7 @@ x_parse_nearest_color (struct device *d, XColor *color, Bufbyte *name,
 }
 
 static int
-x_initialize_color_instance (struct Lisp_Color_Instance *c, Lisp_Object name,
+x_initialize_color_instance (Lisp_Color_Instance *c, Lisp_Object name,
                             Lisp_Object device, Error_behavior errb)
 {
   XColor color;
@@ -271,7 +281,7 @@ x_initialize_color_instance (struct Lisp_Color_Instance *c, Lisp_Object name,
 }
 
 static void
-x_print_color_instance (struct Lisp_Color_Instance *c,
+x_print_color_instance (Lisp_Color_Instance *c,
                        Lisp_Object printcharfun,
                        int escapeflag)
 {
@@ -283,7 +293,7 @@ x_print_color_instance (struct Lisp_Color_Instance *c,
 }
 
 static void
-x_finalize_color_instance (struct Lisp_Color_Instance *c)
+x_finalize_color_instance (Lisp_Color_Instance *c)
 {
   if (c->data)
     {
@@ -306,8 +316,8 @@ x_finalize_color_instance (struct Lisp_Color_Instance *c)
    be comparing their names or pixel values instead. */
 
 static int
-x_color_instance_equal (struct Lisp_Color_Instance *c1,
-                       struct Lisp_Color_Instance *c2,
+x_color_instance_equal (Lisp_Color_Instance *c1,
+                       Lisp_Color_Instance *c2,
                        int depth)
 {
   XColor color1 = COLOR_INSTANCE_X_COLOR (c1);
@@ -318,14 +328,14 @@ x_color_instance_equal (struct Lisp_Color_Instance *c1,
 }
 
 static unsigned long
-x_color_instance_hash (struct Lisp_Color_Instance *c, int depth)
+x_color_instance_hash (Lisp_Color_Instance *c, int depth)
 {
   XColor color = COLOR_INSTANCE_X_COLOR (c);
   return HASH3 (color.red, color.green, color.blue);
 }
 
 static Lisp_Object
-x_color_instance_rgb_components (struct Lisp_Color_Instance *c)
+x_color_instance_rgb_components (Lisp_Color_Instance *c)
 {
   XColor color = COLOR_INSTANCE_X_COLOR (c);
   return (list3 (make_int (color.red),
@@ -342,10 +352,9 @@ x_valid_color_name_p (struct device *d, Lisp_Object color)
 
   CONST char *extname;
 
-  GET_C_STRING_CTEXT_DATA_ALLOCA (color, extname);
+  TO_EXTERNAL_FORMAT (LISP_STRING, color, C_STRING_ALLOCA, extname, Qctext);
 
-  return XParseColor (dpy, cmap,
-                     extname, &c);
+  return XParseColor (dpy, cmap, extname, &c);
 }
 
 \f
@@ -354,20 +363,19 @@ x_valid_color_name_p (struct device *d, Lisp_Object color)
 /************************************************************************/
 
 static int
-x_initialize_font_instance (struct Lisp_Font_Instance *f, Lisp_Object name,
+x_initialize_font_instance (Lisp_Font_Instance *f, Lisp_Object name,
                            Lisp_Object device, Error_behavior errb)
 {
-  Display *dpy;
+  Display *dpy = DEVICE_X_DISPLAY (XDEVICE (device));
   XFontStruct *xf;
   CONST char *extname;
 
-  dpy = DEVICE_X_DISPLAY (XDEVICE (device));
-  GET_C_STRING_CTEXT_DATA_ALLOCA (f->name, extname);
+  TO_EXTERNAL_FORMAT (LISP_STRING, f->name, C_STRING_ALLOCA, extname, Qctext);
   xf = XLoadQueryFont (dpy, extname);
 
   if (!xf)
     {
-      maybe_signal_simple_error ("couldn't load font", f->name,
+      maybe_signal_simple_error ("Couldn't load font", f->name,
                                 Qfont, errb);
       return 0;
     }
@@ -449,14 +457,13 @@ x_initialize_font_instance (struct Lisp_Font_Instance *f, Lisp_Object name,
 }
 
 static void
-x_mark_font_instance (struct Lisp_Font_Instance *f,
-                      void (*markobj) (Lisp_Object))
+x_mark_font_instance (Lisp_Font_Instance *f)
 {
-  ((markobj) (FONT_INSTANCE_X_TRUENAME (f)));
+  mark_object (FONT_INSTANCE_X_TRUENAME (f));
 }
 
 static void
-x_print_font_instance (struct Lisp_Font_Instance *f,
+x_print_font_instance (Lisp_Font_Instance *f,
                       Lisp_Object printcharfun,
                       int escapeflag)
 {
@@ -466,7 +473,7 @@ x_print_font_instance (struct Lisp_Font_Instance *f,
 }
 
 static void
-x_finalize_font_instance (struct Lisp_Font_Instance *f)
+x_finalize_font_instance (Lisp_Font_Instance *f)
 {
 
   if (f->data)
@@ -498,7 +505,7 @@ x_finalize_font_instance (struct Lisp_Font_Instance *f)
    also picking 100dpi adobe fonts over 75dpi adobe fonts even though the
    75dpi are in the path earlier) but sometimes appears to be doing something
    else entirely (for example, removing the bitsream fonts from the path will
-   cause the 75dpi adobe fonts to be used instead of the100dpi, even though
+   cause the 75dpi adobe fonts to be used instead of the 100dpi, even though
    their relative positions in the path (and their names!) have not changed).
 
    The documentation for XSetFontPath() seems to indicate that the order of
@@ -509,7 +516,7 @@ x_finalize_font_instance (struct Lisp_Font_Instance *f)
    truename of the font.  However, there are two problems with using this: the
    first is that the X Protocol Document is quite explicit that all properties
    are optional, so we can't depend on it being there.  The second is that
-   it's concievable that this alleged truename isn't actually accessible as a
+   it's conceivable that this alleged truename isn't actually accessible as a
    font, due to some difference of opinion between the font designers and
    whoever installed the font on the system.
 
@@ -566,7 +573,7 @@ x_finalize_font_instance (struct Lisp_Font_Instance *f)
 static int
 valid_x_font_name_p (Display *dpy, char *name)
 {
-  /* Maybe this should be implemented by callign XLoadFont and trapping
+  /* Maybe this should be implemented by calling XLoadFont and trapping
      the error.  That would be a lot of work, and wasteful as hell, but
      might be more correct.
    */
@@ -766,7 +773,7 @@ x_font_truename (Display *dpy, char *name, XFontStruct *font)
 }
 
 static Lisp_Object
-x_font_instance_truename (struct Lisp_Font_Instance *f, Error_behavior errb)
+x_font_instance_truename (Lisp_Font_Instance *f, Error_behavior errb)
 {
   struct device *d = XDEVICE (f->device);
 
@@ -783,7 +790,7 @@ x_font_instance_truename (struct Lisp_Font_Instance *f, Error_behavior errb)
          Lisp_Object font_instance;
          XSETFONT_INSTANCE (font_instance, f);
 
-         maybe_signal_simple_error ("couldn't determine font truename",
+         maybe_signal_simple_error ("Couldn't determine font truename",
                                   font_instance, Qfont, errb);
          /* Ok, just this once, return the font name as the truename.
             (This is only used by Fequal() right now.) */
@@ -794,7 +801,7 @@ x_font_instance_truename (struct Lisp_Font_Instance *f, Error_behavior errb)
 }
 
 static Lisp_Object
-x_font_instance_properties (struct Lisp_Font_Instance *f)
+x_font_instance_properties (Lisp_Font_Instance *f)
 {
   struct device *d = XDEVICE (f->device);
   int i;
@@ -854,12 +861,14 @@ x_list_fonts (Lisp_Object pattern, Lisp_Object device)
   Lisp_Object result = Qnil;
   CONST char *patternext;
 
-  GET_C_STRING_BINARY_DATA_ALLOCA (pattern, patternext);
+  TO_EXTERNAL_FORMAT (LISP_STRING, pattern,
+                     C_STRING_ALLOCA, patternext,
+                     Qbinary);
 
   names = XListFonts (DEVICE_X_DISPLAY (XDEVICE (device)),
                      patternext, MAX_FONT_COUNT, &count);
   while (count--)
-    result = Fcons (build_ext_string (names [count], FORMAT_BINARY), result);
+    result = Fcons (build_ext_string (names [count], Qbinary), result);
   if (names)
     XFreeFontNames (names);
   return result;
@@ -927,20 +936,24 @@ x_find_charset_font (Lisp_Object device, Lisp_Object font, Lisp_Object charset)
   CONST char *patternext;
   int i;
 
-  GET_C_STRING_BINARY_DATA_ALLOCA (font, patternext);
+  TO_EXTERNAL_FORMAT (LISP_STRING, font,
+                     C_STRING_ALLOCA, patternext,
+                     Qbinary);
 
   names = XListFonts (DEVICE_X_DISPLAY (XDEVICE (device)),
                      patternext, MAX_FONT_COUNT, &count);
-  /* ### This code seems awfully bogus -- mrb */
+  /* #### This code seems awfully bogus -- mrb */
   for (i = 0; i < count; i ++)
     {
-      CONST Bufbyte *intname;
+      CONST char *intname;
 
-      GET_C_CHARPTR_INT_BINARY_DATA_ALLOCA (names[i], intname);
+      TO_INTERNAL_FORMAT (C_STRING, names[i],
+                         C_STRING_ALLOCA, intname,
+                         Qbinary);
       if (x_font_spec_matches_charset (XDEVICE (device), charset,
-                                      intname, Qnil, 0, -1))
+                                      (Bufbyte *) intname, Qnil, 0, -1))
        {
-         result = build_string ((char *) intname);
+         result = build_string (intname);
          break;
        }
     }