/* X-specific Lisp objects.
   Copyright (C) 1993, 1994 Free Software Foundation, Inc.
   Copyright (C) 1995 Board of Trustees, University of Illinois
   Copyright (C) 1995 Tinker Systems
   Copyright (C) 1995 Ben Wing

This file is part of XEmacs.

XEmacs is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by the
Free Software Foundation; either version 2, or (at your option) any
later version.

XEmacs is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
for more details.

You should have received a copy of the GNU General Public License
along with XEmacs; see the file COPYING.  If not, write to the Free
Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */

/* Synched up with: Not in FSF. */

/* Authors: Jamie Zawinski, Chuck Thompson, Ben Wing */

#include <config.h>
#include "lisp.h"

#include "device-x.h"
#include "frame-x.h"
#include "glyphs-x.h"
#include "objects-x.h"
#include "xmu.h"

#include "buffer.h"
#include "insdel.h"

#include "sysfile.h"

/* #### This isn't going to be sufficient if we ever want to handle
   multiple screens on a single display. */
#define LISP_DEVICE_TO_X_SCREEN(dev)					\
  XDefaultScreenOfDisplay (DEVICE_X_DISPLAY (XDEVICE (dev)))

Lisp_Object Qxbm;
#ifdef HAVE_XPM
Lisp_Object Qxpm;
#endif
#ifdef HAVE_XFACE
Lisp_Object Qxface;
#endif

Lisp_Object Q_mask_file, Q_mask_data;
#ifdef HAVE_XPM
Lisp_Object Q_color_symbols;
#endif

#include "bitmaps.h"


/************************************************************************/
/*                           image instances                           */
/************************************************************************/

/* #### The generic image-instance stuff needs to be moved into
   objects.c */
Lisp_Object Qimage_instancep;
static Lisp_Object mark_image_instance (Lisp_Object, void (*) (Lisp_Object));
static void print_image_instance (Lisp_Object, Lisp_Object, int);
static void finalize_image_instance (void *, int);
static int image_instance_equal (Lisp_Object o1, Lisp_Object o2, int depth);
static unsigned long image_instance_hash (Lisp_Object obj, int depth);
DEFINE_LRECORD_IMPLEMENTATION ("image-instance", image_instance,
			       mark_image_instance, print_image_instance,
			       finalize_image_instance, image_instance_equal,
			       image_instance_hash,
			       struct Lisp_Image_Instance);

static Lisp_Object
mark_image_instance (Lisp_Object obj, void (*markobj) (Lisp_Object))
{
  struct Lisp_Image_Instance *p = XIMAGE_INSTANCE (obj);
  ((markobj) (p->filename));
  return p->device;
}


static void
print_image_instance (Lisp_Object obj, Lisp_Object printcharfun,
		       int escapeflag)
{
  char buf[100];
  struct Lisp_Image_Instance *p = XIMAGE_INSTANCE (obj);
  char *s;
  if (print_readably)
    error ("printing unreadable object #<image-instance 0x%x>",
	   p->header.uid);

  write_c_string ((p->depth ? "#<image-instance " : "#<bitmap-instance "),
		  printcharfun);
  if (STRINGP (p->filename) &&
      (s = strrchr ((char *) string_data (XSTRING (p->filename)), '/')))
    print_internal (build_string (s + 1), printcharfun, 1);
  else
    print_internal (p->filename, printcharfun, 0);
  if (p->depth > 1)
    sprintf (buf, " %dx%dx%d", p->width, p->height, p->depth);
  else
    sprintf (buf, " %dx%d", p->width, p->height);
  write_c_string (buf, printcharfun);
  if (p->x || p->y)
    {
      sprintf (buf, " @%d,%d", p->x, p->y);
      write_c_string (buf, printcharfun);
    }
  sprintf (buf, " (0x%lx", (unsigned long) p->pixmap);
  write_c_string (buf, printcharfun);
  if (p->mask)
    {
      sprintf (buf, "/0x%lx", (unsigned long) p->mask);
      write_c_string (buf, printcharfun);
    }
  sprintf (buf, ") 0x%x>", p->header.uid);
  write_c_string (buf, printcharfun);
}

static void
finalize_image_instance (void *header, int for_disksave)
{
  struct Lisp_Image_Instance *p = (struct Lisp_Image_Instance *) header;
  Screen *scr = LISP_DEVICE_TO_X_SCREEN (p->device);
  if (for_disksave) finalose (p);
  if (p->pixmap)
    {
      XFreePixmap (DisplayOfScreen (scr), p->pixmap);
      p->pixmap = 0;
    }
  if (p->mask && p->mask != p->pixmap)
    {
      XFreePixmap (DisplayOfScreen (scr), p->mask);
      p->mask = 0;
    }
  if (p->npixels != 0)
    {
      XFreeColors (DisplayOfScreen (scr),
		   DefaultColormapOfScreen (scr),
		   p->pixels, p->npixels, 0);
      p->npixels = 0;
    }
  if (p->pixels)
    {
      xfree (p->pixels);
      p->pixels = 0;
    }
}

/* Image instances are equal if their names are non-nil and equal.
   This means that two image instances constructed from the same lisp data
   won't be equal, but that's life.  (It's better than all lisp-data pixmap
   instances being equal, and it's also better than keeping that lisp data
   around for the lifetime of the image instance.)
 */
static int
image_instance_equal (Lisp_Object o1, Lisp_Object o2, int depth)
{
  if (NILP (XIMAGE_INSTANCE (o1)->filename))
    return 0;
  /* In case one has been colorized and the other hasn't. */
  if (XIMAGE_INSTANCE (o1)->npixels != XIMAGE_INSTANCE (o2)->npixels)
    return 0;
  return (internal_equal (XIMAGE_INSTANCE (o1)->filename,
			  XIMAGE_INSTANCE (o2)->filename,
			  depth + 1));
}

static unsigned long
image_instance_hash (Lisp_Object obj, int depth)
{
  return HASH2 (XIMAGE_INSTANCE (obj)->npixels,
		internal_hash (XIMAGE_INSTANCE (obj)->filename, depth + 1));
}

static int
valid_xbm_inline_p (Lisp_Object width, Lisp_Object height, Lisp_Object data,
		    int no_error)
{
  if (!INTP (width) || !INTP (height) || !STRINGP (data))
    {
      if (!no_error)
	signal_simple_error ("Must be (width height bits)",
			     vector3 (width, height, data));
      return 0;
    }

  if (XINT (width) <= 0)
    {
      if (!no_error)
	signal_simple_error ("Width must be > 0", width);
      return 0;
    }

  if (XINT (height) <= 0)
    {
      if (!no_error)
	signal_simple_error ("Height must be > 0", height);
      return 0;
    }

  if (((unsigned) (XINT (width) * XINT (height)) / 8)
      > string_length (XSTRING (data)))
    {
      if (!no_error)
	signal_simple_error ("data is too short for W and H",
			     vector3 (width, height, data));
      return 0;
    }

  return 1;
}

int
x_valid_image_instantiator_p (Lisp_Object instantiator, int no_error)
{
  Lisp_Object *elt;
  int instantiator_len;
  Lisp_Object type;
  char allowable[200];
  int file_was_specified = 0;
  int data_was_specified = 0;

  if (!VECTORP (instantiator))
    {
      if (!no_error)
	CHECK_VECTOR (instantiator, 0);
      return 0;
    }

  elt = vector_data (XVECTOR (instantiator));
  instantiator_len = XVECTOR (instantiator)->size;

  if (instantiator_len < 3)
    {
      if (!no_error)
	signal_simple_error ("Vector length must be at least 3",
			     instantiator);
      return 0;
    }

  if (!SYMBOLP (elt[0]))
    {
      if (!no_error)
	signal_simple_error ("Image type must be symbol", elt[0]);
      return 0;
    }

  if (! (instantiator_len & 1))
    {
      if (!no_error)
	signal_simple_error ("Must have an odd number of elements",
			     instantiator);
      return 0;
    }

  /* OK, check the type. */

  type = elt[0];
  allowable[0] = '\0';
  do
    {
      if (EQ (type, Qxbm))
	break;
      else
	strcat (allowable, ", 'xbm");
#if defined (HAVE_XPM)
      if (EQ (type, Qxpm))
	break;
      else
	strcat (allowable, ", 'xpm");
#endif
#if defined (HAVE_XFACE)
      if (EQ (type, Qxface))
	break;
      else
	strcat (allowable, ", 'xface");
#endif
      
      /* Add more types: TIFF, GIF, JPEG, ... */
      
      /* OK, time for an error message */
      if (no_error)
	return 0;
      {
	char bigstr[300];
	strcpy (bigstr, "Allowable types are ");
	/* skip over initial comma-space */
	strcat (bigstr, allowable + 2);
	signal_simple_error (bigstr, type);
      }
    }
  while (0);

  /* Now check the keywords. */

  elt++;
  instantiator_len--;
  while (instantiator_len > 0)
    {
      Lisp_Object keyword = elt[0];
      Lisp_Object data = elt[1];
      if (EQ (keyword, Q_data))
	data_was_specified = 1;

      if (EQ (keyword, Q_file))
	{
	  file_was_specified = 1;
	  if (!STRINGP (data))
	    {
	      if (!no_error)
		CHECK_STRING (data, 0);
	      return 0;
	    }
	}
      else if (EQ (type, Qxbm) &&
	       (EQ (keyword, Q_data) || EQ (keyword, Q_mask_data)))
	{
	  if (!CONSP (data))
	    {
	      if (!no_error)
		CHECK_CONS (data, 0);
	      return 0;
	    }
	  if (!CONSP (XCDR (data)) || !CONSP (XCDR (XCDR (data))) ||
	      !NILP (XCDR (XCDR (XCDR (data)))))
	    {
	      if (!no_error)
		signal_simple_error ("Must be list of 3 elements", data);
	      return 0;
	    }
	  if (!valid_xbm_inline_p (XCAR (data), XCAR (XCDR (data)),
				   XCAR (XCDR (XCDR (data))),
				   no_error))
	    /* error would be signalled already */
	    return 0;
	}
      else if (EQ (type, Qxbm) && EQ (keyword, Q_mask_file))
	{
	  if (!STRINGP (data))
	    {
	      if (!no_error)
		CHECK_STRING (data, 0);
	      return 0;
	    }
	}
      else if (EQ (keyword, Q_data))
	{
	  if (!STRINGP (data))
	    {
	      if (!no_error)
		CHECK_STRING (data, 0);
	      return 0;
	    }
	}
#ifdef HAVE_XPM
      /* XPM, with color-symbol-alist */
      else if (EQ (type, Qxpm) && EQ (keyword, Q_color_symbols))
	{
	  /* check for valid color-symbol-alist */
	  Lisp_Object rest;
	  
	  for (rest = data; !NILP (rest); rest = XCDR (rest))
	    {
	      if (!CONSP (rest) ||
		  !CONSP (XCAR (rest)) ||
		  !STRINGP (XCAR (XCAR (rest))) ||
		  (!STRINGP (XCDR (XCAR (rest))) &&
		   !COLOR_SPECIFIERP (XCDR (XCAR (rest)))))
		{
		  if (!no_error)
		    signal_simple_error ("Invalid color symbol alist",
					 data);
		  return 0;
		}
	    }
	}
#endif /* HAVE_XPM */
      else
	{
	  /* error. */
	  if (!no_error)
	    {
	      if (EQ (type, Qxbm))
		signal_simple_error ("Valid keywords are :file, :data, :mask-file, :mask-data", keyword);
#ifdef HAVE_XPM
	      if (EQ (type, Qxpm))
		signal_simple_error ("Valid keywords are :file, :data, :color-symbols", keyword);
#endif
#ifdef HAVE_XFACE
	      if (EQ (type, Qxface))
		signal_simple_error ("Valid keywords are :file, :data", keyword);
#endif
	    }
	  return 0;
	}

      elt += 2;
      instantiator_len -= 2;
    }

  if (!file_was_specified && !data_was_specified)
    {
      if (!no_error)
	signal_simple_error ("Must supply either :file or :data",
			     instantiator);
      return 0;
    }

  /* It's OK. */
  return 1;
}

static Lisp_Object
find_keyword_in_vector (Lisp_Object vector, Lisp_Object keyword)
{
  Lisp_Object *elt;
  int instantiator_len;

  elt = vector_data (XVECTOR (vector));
  instantiator_len = XVECTOR (vector)->size;

  elt++;
  instantiator_len--;

  while (instantiator_len > 0)
    {
      if (EQ (elt[0], keyword))
	return elt[1];
      elt += 2;
      instantiator_len -= 2;
    }

  return Qunbound;
}

static Lisp_Object
allocate_image_instance (Lisp_Object device)
{
  struct Lisp_Image_Instance *lp =
    alloc_lcrecord (sizeof (struct Lisp_Image_Instance),
		    lrecord_image_instance);
  Lisp_Object val = Qnil;
  lp->filename = Qnil;
  lp->device = device;
  lp->pixmap = 0;
  lp->mask = 0;
  lp->x = 0;
  lp->y = 0;
  lp->width = 0;
  lp->height = 0;
  lp->depth = 0;
  lp->pixels = 0;
  lp->npixels = 0;
  XSETIMAGE_INSTANCE (val, lp);
  return val;
}


/* Where bitmaps are; initialized from resource database */
Lisp_Object Vx_bitmap_file_path;

#ifndef BITMAPDIR
#define BITMAPDIR "/usr/include/X11/bitmaps"
#endif

#define USE_XBMLANGPATH

static Lisp_Object
locate_pixmap_file (Lisp_Object name)
{
  /* This function can GC if IN_REDISPLAY is false */
  Display *display;

  /* Check non-absolute pathnames with a directory component relative to
     the search path; that's the way Xt does it. */
  /* #### Unix-specific */
  if (string_byte (XSTRING (name), 0) == '/' ||
      (string_byte (XSTRING (name), 0) == '.' &&
       (string_byte (XSTRING (name), 1) == '/' ||
	(string_byte (XSTRING (name), 1) == '.' &&
	 (string_byte (XSTRING (name), 2) == '/')))))
    {
      if (!NILP (Ffile_readable_p (name)))
	return name;
      else
	return Qnil;
    }

  if (NILP (Vdefault_x_device))
    /* This may occur during intialization. */
    return Qnil;
  else
    /* We only check the bitmapFilePath resource on the original X device. */
    display = DEVICE_X_DISPLAY (XDEVICE (Vdefault_x_device));

#ifdef USE_XBMLANGPATH
  {
    char *path = egetenv ("XBMLANGPATH");
    SubstitutionRec subs[1];
    subs[0].match = 'B';
    subs[0].substitution = (char *) string_data (XSTRING (name));
    /* #### Motif uses a big hairy default if $XBMLANGPATH isn't set.
       We don't.  If you want it used, set it. */
    if (path &&
	(path = XtResolvePathname (display, "bitmaps", 0, 0, path,
				   subs, XtNumber (subs), 0)))
      {
	name = build_string (path);
	XtFree (path);
        return (name);
      }
  }
#endif

  if (NILP (Vx_bitmap_file_path))
    {
      char *type = 0;
      XrmValue value;
      if (XrmGetResource (XtDatabase (display),
			  "bitmapFilePath", "BitmapFilePath", &type, &value)
	  && !strcmp (type, "String"))
	Vx_bitmap_file_path = decode_env_path (0, (char *) value.addr);
      Vx_bitmap_file_path = nconc2 (Vx_bitmap_file_path,
				    (list1 (build_string (BITMAPDIR))));
    }

  {
    Lisp_Object found;
    if (locate_file (Vx_bitmap_file_path, name, "", &found, R_OK) < 0)
      {
	Lisp_Object temp = list1 (Vdata_directory);
	struct gcpro gcpro1;

	GCPRO1 (temp);
	locate_file (temp, name, "", &found, R_OK);
	UNGCPRO;
      }

    return (found);
  }
}

#ifdef HAVE_XPM
 /* xpm 3.2g and better has XpmCreatePixmapFromBuffer()...
    There was no version number in xpm.h before 3.3, but this should do.
  */
# if (XpmVersion >= 3) || defined(XpmExactColors)
#  define XPM_DOES_BUFFERS
# endif

Lisp_Object Vxpm_color_symbols;

static Lisp_Object
evaluate_xpm_color_symbols (int no_errors)
{
  Lisp_Object rest, results = Qnil;
  struct gcpro gcpro1, gcpro2;

  GCPRO2 (rest, results);
  for (rest = Vxpm_color_symbols; !NILP (rest); rest = XCDR (rest))
    {
      Lisp_Object name, value, cons;

      if (!CONSP (rest))
	{
	  if (!no_errors)
	    CHECK_CONS (rest, 0);
	  UNGCPRO;
	  return Qnil;
	}
      cons = XCAR (rest);
      if (!CONSP (cons))
	{
	  if (!no_errors)
	    CHECK_CONS (cons, 0);
	  UNGCPRO;
	  return Qnil;
	}
      name = XCAR (cons);
      if (!STRINGP (name))
	{
	  if (!no_errors)
	    CHECK_STRING (name, 0);
	  UNGCPRO;
	  return Qnil;
	}
      value = XCDR (cons);
      if (!CONSP (value))
	{
	  if (!no_errors)
	    CHECK_CONS (value, 0);
	  UNGCPRO;
	  return Qnil;
	}
      value = XCAR (value);
      value = Feval (value);
      if (NILP (value))
	continue;
      if (!STRINGP (value) && !COLOR_SPECIFIERP (value))
	{
	  if (!no_errors)
	    signal_simple_error
	      ("Result from xpm-color-symbols eval must be nil, string, or color",
	       value);
	  UNGCPRO;
	  return Qnil;
	}
      results = Fcons (Fcons (name, value), results);
    }
  UNGCPRO;			/* no more evaluation */
  return results;
}

static XpmColorSymbol *
extract_xpm_color_names (XpmAttributes *xpmattrs, Lisp_Object device,
			 Lisp_Object color_symbol_alist, int no_errors)
{
  /* This function can GC */
  Screen *xs = LISP_DEVICE_TO_X_SCREEN (device);
  Display *dpy = DisplayOfScreen (xs);
  Colormap cmap = DefaultColormapOfScreen (xs);
  XColor color;
  Lisp_Object rest;
  Lisp_Object results = Qnil;
  int i;
  XpmColorSymbol *symbols;
  struct gcpro gcpro1, gcpro2;

  GCPRO2 (results, device);

  /* We built up results to be (("name" . #<color>) ...) so that if an
     error happens we don't lose any malloc()ed data, or more importantly,
     leave any pixels allocated in the server. */
  i = 0;
  LIST_LOOP (rest, color_symbol_alist)
    {
      Lisp_Object cons = XCAR (rest);
      Lisp_Object name = XCAR (cons);
      Lisp_Object value = XCDR (cons);
      if (NILP (value))
	continue;
      if (STRINGP (value))
	value = Fmake_color_instance (value, device, no_errors ? Qt : Qnil);
      else
        {
          assert (COLOR_SPECIFIERP (value));
          value = Fspecifier_instance (value, device, Qnil, Qnil);
        }
      if (NILP (value))
        continue;
      results = Fcons (Fcons (name, value), results);
      i++;
    }
  UNGCPRO;			/* no more evaluation */

  if (i == 0) return 0;

  symbols = (XpmColorSymbol *) xmalloc (i * sizeof (XpmColorSymbol));
  xpmattrs->valuemask |= XpmColorSymbols;
  xpmattrs->colorsymbols = symbols;
  xpmattrs->numsymbols = i;

  while (--i >= 0)
    {
      Lisp_Object cons = XCAR (results);
      color = COLOR_INSTANCE_X_COLOR (XCOLOR_INSTANCE (XCDR (cons)));
      /* Duplicate the pixel value so that we still have a lock on it if
	 the pixel we were passed is later freed. */
      if (! XAllocColor (dpy, cmap, &color))
	abort ();  /* it must be allocable since we're just duplicating it */

      symbols [i].name = (char *) string_data (XSTRING (XCAR (cons)));
      symbols [i].pixel = color.pixel;
      symbols [i].value = 0;
      results = XCDR (results);
      free_cons (XCONS (cons));
    }
  return symbols;
}

static void
xpm_free (XpmAttributes *xpmattrs)
{
  /* Could conceivably lose if XpmXXX returned an error without first
     initializing this structure, if we didn't know that initializing it
     to all zeros was ok (and also that it's ok to call XpmFreeAttributes()
     multiple times, since it zeros slots as it frees them...) */
  XpmFreeAttributes (xpmattrs);
}

static Lisp_Object
try_reading_xpm_bitmap (Lisp_Object pi, Lisp_Object name,
			Lisp_Object color_symbol_alist,
			int raw_data_p, int retry_in_mono, int no_errors)
{
  /* This function can GC */
  int result;
  Lisp_Object device = XIMAGE_INSTANCE (pi)->device;
  Screen *xs = LISP_DEVICE_TO_X_SCREEN (device);

  Pixmap pixmap;
  Pixmap mask = 0;
  XpmAttributes xpmattrs;

  {
    XpmColorSymbol *color_symbols;
    struct gcpro gcpro1;

  retry:

    memset (&xpmattrs, 0, sizeof (xpmattrs)); /* want XpmInitAttributes() */
    xpmattrs.valuemask = XpmReturnPixels;
    if (retry_in_mono)
      {
#ifdef XpmColorKey	/* 3.2g or better */
	/* Without this, we get a 1-bit version of the color image, which
	   isn't quite right.  With this, we get the mono image, which might
	   be very different looking. */
	xpmattrs.valuemask |= XpmColorKey;
	xpmattrs.color_key = XPM_MONO;
#endif
	xpmattrs.depth = 1;
	xpmattrs.valuemask |= XpmDepth;
      }
    else
      {
	xpmattrs.closeness = 65535;
	xpmattrs.valuemask |= XpmCloseness;
      }

    if (UNBOUNDP (color_symbol_alist))
      color_symbol_alist = evaluate_xpm_color_symbols (no_errors);

    /* perhaps not necessary, but ... */
    GCPRO1 (color_symbol_alist);
    color_symbols = extract_xpm_color_names (&xpmattrs, device,
					     color_symbol_alist,
					     no_errors);
    UNGCPRO;

# ifdef XPM_DOES_BUFFERS
    if (raw_data_p)
      result = XpmCreatePixmapFromBuffer (DisplayOfScreen (xs),
					  RootWindowOfScreen (xs),
					  (char *)
					  string_data (XSTRING (name)),
					  &pixmap, &mask, &xpmattrs);
    else
# endif/* XPM_DOES_BUFFERS */
      result = XpmReadFileToPixmap (DisplayOfScreen (xs),
				    RootWindowOfScreen (xs), 
                                    (char *) string_data (XSTRING (name)),
				    &pixmap, &mask, &xpmattrs);

    if (color_symbols)
      {
	xfree (color_symbols);
	xpmattrs.colorsymbols = 0; /* in case XpmFreeAttr is too smart... */
	xpmattrs.numsymbols = 0;
      }
  }

  switch (result)
    {
    case XpmSuccess:
      break;
    case XpmFileInvalid:
      {
	xpm_free (&xpmattrs);
	if (raw_data_p)
	  {
	    if (!no_errors)
	      signal_simple_error ("invalid XPM data", name);
	    else
	      return Qnil;
	  }
	return (Qnil);
      }
    case XpmColorFailed:
      {
	xpm_free (&xpmattrs);
	if (retry_in_mono)
	  {
	    if (!no_errors)
	      /* second time; blow out. */
	      signal_double_file_error ("Reading pixmap file",
					"color allocation failed",
					name);
	    else
	      return Qnil;
	  }
	else
	  retry_in_mono = 1;

	goto retry;
      }
    case XpmColorError:
      {
	/* Maybe we should just read it in monochrome instead of allowing the
	   colors to be substituted?
	   */
	if (raw_data_p)
	  {
	    if (!no_errors)
	      message ("color substitution performed for XPM data");
	    else
	      return Qnil;
	  }
	else
	  {
	    if (!no_errors)
	      message ("color substitution performed for file \"%s\"", 
		       string_data (XSTRING (name)));
	    else
	      return Qnil;
	  }
	break;
      }
    case XpmNoMemory:
      {
	xpm_free (&xpmattrs);
	/* DO NOT put the test inside of the call to signal_double_file_error.
	   It will mess up make-msgfile. */
	if (raw_data_p)
	  {
	    if (!no_errors)
	      signal_double_file_error ("Parsing pixmap data",
					"out of memory", name);
	    else
	      return Qnil;
	  }
	else
	  {
	    if (!no_errors)
	      signal_double_file_error ("Reading pixmap file",
					"out of memory", name);
	    else
	      return Qnil;
	  }
      }
    case XpmOpenFailed:
      {
	xpm_free (&xpmattrs);
	if (!no_errors)
	  signal_double_file_error ("Opening pixmap file",
				    "no such file or directory", name);
	else
	  return Qnil;
      }
    default:
      {
	xpm_free (&xpmattrs);
	/* DO NOT put the test inside of the call to signal_double_file_error.
	   It will mess up make-msgfile. */
	if (raw_data_p)
	  {
	    if (!no_errors)
	      signal_double_file_error_2 ("Parsing pixmap data",
					  "unknown error code",
					  make_number (result), name);
	    else
	      return Qnil;
	  }
	else
	  {
	    if (!no_errors)
	      signal_double_file_error_2 ("Reading pixmap file",
					  "unknown error code",
					  make_number (result), name);
	    else
	      return Qnil;
	  }
      }
    }
  {
    /* XpmReadFileToPixmap() doesn't return the depth (bogus!) so we need to
       get it ourself.  (No, xpmattrs.depth is not it; that's an input slot,
       not output.)  We could just assume that it has the same depth as the
       root window, but some devices allow more than one depth, so that isn't
       necessarily correct (I guess?) */
    Window root;
    int x, y;
    unsigned int w2, h2, bw;

    unsigned int w = xpmattrs.width;
    unsigned int h = xpmattrs.height;
    unsigned int d;
    int xhot = ((xpmattrs.valuemask & XpmHotspot) ? xpmattrs.x_hotspot : -1);
    int yhot = ((xpmattrs.valuemask & XpmHotspot) ? xpmattrs.y_hotspot : -1);
    int npixels = xpmattrs.npixels;
    Pixel *pixels = 0;

    if (npixels != 0)
      {
	pixels = xmalloc (npixels * sizeof (Pixel));
	memcpy (pixels, xpmattrs.pixels, npixels * sizeof (Pixel));
      }
    else
      pixels = 0;

    xpm_free (&xpmattrs);	/* after we've read pixels and hotspot */

    if (!XGetGeometry (DisplayOfScreen (xs), pixmap, &root, &x, &y,
                       &w2, &h2, &bw, &d))
      abort ();
    if (w != w2 || h != h2)
      abort ();

    {
      struct Lisp_Image_Instance *ppp = XIMAGE_INSTANCE (pi);

      if (!raw_data_p)
	ppp->filename = name;
      ppp->x = xhot < 0 ? 0 : xhot;
      ppp->y = yhot < 0 ? 0 : yhot;
      ppp->pixmap = pixmap;
      ppp->mask = mask;
      ppp->width = w;
      ppp->height = h;
      ppp->depth = d;
      ppp->pixels = pixels;
      ppp->npixels = npixels;
    }
  }

  return pi;
}

static Lisp_Object
pixmap_to_lisp_data (Lisp_Object name)
{
  char **data;
  int result;

  result = XpmReadFileToData ((char *) string_data (XSTRING (name)), &data);

  if (result == XpmSuccess)
    {
      Lisp_Object retval;
      Lisp_Object old_inhibit_quit = Vinhibit_quit;
      struct buffer *old_buffer = current_buffer;
      Lisp_Object temp_buffer =
	Fget_buffer_create (build_string (" *pixmap conversion*"));
      int elt;
      int height, width, ncolors;
      struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;

      GCPRO4 (name, retval, old_inhibit_quit, temp_buffer);

      Vinhibit_quit = Qt;
      set_buffer_internal (XBUFFER (temp_buffer));
      Ferase_buffer ();

      buffer_insert_c_string (current_buffer, "/* XPM */\r");
      buffer_insert_c_string (current_buffer, "static char *pixmap[] = {\r");

      sscanf (data[0], "%d %d %d", &height, &width, &ncolors);
      for (elt = 0; elt <= width + ncolors; elt++)
	{
	  buffer_insert_c_string (current_buffer, "\"");
	  buffer_insert_c_string (current_buffer, data[elt]);

	  if (elt < width + ncolors)
	    buffer_insert_c_string (current_buffer, "\",\r");
	  else
	    buffer_insert_c_string (current_buffer, "\"};\r");
	}

      retval = Fbuffer_string ();
      XpmFree (data);

      set_buffer_internal (old_buffer);
      Vinhibit_quit = old_inhibit_quit;

      UNGCPRO;
      return retval;
    }

  return Qnil;
}

static Lisp_Object
make_image_instance_from_xpm_inline (Lisp_Object pi, Lisp_Object data,
				      Lisp_Object color_symbol_alist,
				      int retry_in_mono, int no_errors)
{
#ifndef XPM_DOES_BUFFERS
  if (!no_errors)
    signal_simple_error ("XPM library is too old: no raw data", data);
  return Qnil;
#endif /* !XPM_DOES_BUFFERS */
  return try_reading_xpm_bitmap (pi, data, color_symbol_alist, 1,
				 retry_in_mono, no_errors);
}

static Lisp_Object
make_image_instance_from_xpm_file (Lisp_Object pi, Lisp_Object data,
				    Lisp_Object color_symbol_alist,
				    int retry_in_mono, int no_errors)
{
  return try_reading_xpm_bitmap (pi, data, color_symbol_alist, 0,
				 retry_in_mono, no_errors);
}

#endif /* HAVE_XPM */

static Pixmap
pixmap_from_xbm_inline (Lisp_Object device, int width, int height,
			char *bits)
{
  Screen *screen = LISP_DEVICE_TO_X_SCREEN (device);
  return XCreatePixmapFromBitmapData (DisplayOfScreen (screen),
				      RootWindowOfScreen (screen),
				      bits, width, height,
				      1, 0, 1);
}

static void
make_image_instance_from_xbm_inline_1 (Lisp_Object pi,
					int width, int height,
					unsigned char *bits)
{
  XIMAGE_INSTANCE (pi)->pixmap =
    pixmap_from_xbm_inline (XIMAGE_INSTANCE (pi)->device,
			    width, height, (char *) bits);
  XIMAGE_INSTANCE (pi)->width = width;
  XIMAGE_INSTANCE (pi)->height = height;
}

static Lisp_Object
make_image_instance_from_xbm_inline (Lisp_Object pi,
				     Lisp_Object data,
				     Lisp_Object mask,
				     int no_errors)
{
  make_image_instance_from_xbm_inline_1
    (pi, XINT (XCAR (data)), XINT (XCAR (XCDR (data))),
     string_data (XSTRING (XCAR (XCDR (XCDR (data))))));
								  
  if (!UNBOUNDP (mask))
    XIMAGE_INSTANCE (pi)->mask =
      pixmap_from_xbm_inline
	(XIMAGE_INSTANCE (pi)->device,
	 XINT (XCAR (mask)), XINT (XCAR (XCDR (mask))),
	 (char *) string_data (XSTRING (XCAR (XCDR (XCDR (mask))))));

  return pi;
}

static Lisp_Object
try_reading_Xmu_bitmap (Lisp_Object pi, Lisp_Object fullname, int no_errors,
			int ok_if_data_invalid)
{
  unsigned int w, h;
  int xhot, yhot;
  unsigned char *data;
  int result;

  result = XmuReadBitmapDataFromFile ((char *)
				      string_data (XSTRING (fullname)),
				      &w, &h, &data, &xhot, &yhot);

  switch (result)
    {
    case BitmapSuccess:
      {
	make_image_instance_from_xbm_inline_1 (pi, w, h, data);
	XIMAGE_INSTANCE (pi)->x = xhot;
	XIMAGE_INSTANCE (pi)->y = yhot;
	XIMAGE_INSTANCE (pi)->filename = fullname;
	XFree ((char *) data);
	return pi;
      }
    case BitmapOpenFailed:
      {
	if (!no_errors)
	  /* should never happen */
	  signal_double_file_error ("Opening bitmap file",
				    "no such file or directory",
				    fullname);
	return Qnil;
      }
    case BitmapFileInvalid:
      {
	if (!no_errors && !ok_if_data_invalid)
	  signal_double_file_error ("Reading bitmap file",
				    "invalid data in file",
				    fullname);
	if (ok_if_data_invalid)
	  return Qt;
	return Qnil;
      }
    case BitmapNoMemory:
      {
	if (!no_errors)
	  signal_double_file_error ("Reading bitmap file",
				    "out of memory",
				    fullname);
	return Qnil;
      }
    default:
      {
	if (!no_errors)
	  signal_double_file_error_2 ("Reading bitmap file",
				      "unknown error code",
				      make_number (result), fullname);
	return Qnil;
      }
    }

  return Qnil; /* not reached */
}

static Lisp_Object
make_image_instance_from_xbm_file (Lisp_Object pi,
				    Lisp_Object filename,
				    int no_errors)
{
  Lisp_Object fullname = locate_pixmap_file (filename);
  if (NILP (fullname))
    {
      if (!no_errors)
	signal_double_file_error ("Opening pixmap file",
				  "no such file or directory",
				  filename);
      else
	return Qnil;
    }

  return try_reading_Xmu_bitmap (pi, fullname, no_errors, 0);
}

static Lisp_Object
bitmap_to_lisp_data (Lisp_Object name)
{
  unsigned int w, h;
  int xhot, yhot;
  Bufbyte *data;
  int result;

  result = XmuReadBitmapDataFromFile ((char *) string_data (XSTRING (name)),
				      &w, &h, &data, &xhot, &yhot);

  if (result == BitmapSuccess)
    {
      Lisp_Object retval;
      int len = (w * h + 7) / 8;

      retval = list3 (make_number (w), make_number (h),
		      make_string (data, len));
      XFree ((char *) data);
      return retval;
    }

  return Qnil;
}

#ifdef HAVE_XFACE

/* We have to define SYSV32 so that compface.h includes string.h
   instead of strings.h. */
#define SYSV32
#include <compface.h>
jmp_buf comp_env;
#undef SYSV32

static Lisp_Object 
make_image_instance_from_xface (Lisp_Object pi, Lisp_Object data,
				 int no_error)
{
  int i, status;
  char *p, *bits, *bp, *emsg = NULL, *dstring;

  dstring = (char *) string_data (XSTRING (data));

  if ((p = strchr (dstring, ':')))
    {
      dstring = p + 1;
    }

  if (!(status = setjmp (comp_env)))
    {
      UnCompAll (dstring);
      UnGenFace ();
    }

  switch (status)
    {
    case -2:
      emsg = "uncompface: internal error";
      break;
    case -1:
      emsg = "uncompface: insufficient or invalid data";
      break;
    case 1:
      emsg = "uncompface: excess data ignored";
      break;
    }

  if (emsg && !no_error)
    {
      signal_simple_error (emsg, data);
    }
  else if (emsg)
    {
      return Qnil;
    }

  bp = bits = (char *) alloca (PIXELS / 8);

  /* the compface library exports char F[], which uses a single byte per
     pixel to represent a 48x48 bitmap.  Yuck. */
  for (i = 0, p = F; i < (PIXELS / 8); ++i)
    {
      int n, b;
      /* reverse the bit order of each byte... */
      for (b = n = 0; b < 8; ++b)
	{
	  n |= ((*p++) << b);
	}
      *bp++ = (char) n;
    }

  make_image_instance_from_xbm_inline_1 (pi, 48, 48, (unsigned char *) bits);
  return pi;
}
#endif /* HAVE_XFACE */

static Lisp_Object
make_image_instance_from_unknown_filename (Lisp_Object pi,
					   Lisp_Object name,
					   int retry_in_mono,
					   int no_errors)
{
  Lisp_Object result;
  Lisp_Object file = locate_pixmap_file (name);
  struct gcpro gcpro1;

  if (NILP (file))
    {
      if (!no_errors)
	signal_double_file_error ("Opening pixmap file",
				  "no such file or directory",
				  name);
      return Qnil;
    }
  name = file;
  
  GCPRO1 (file);
  result = try_reading_Xmu_bitmap (pi, name, no_errors, 1);
  if (!EQ (result, Qt))
    /* Qt means an invalid format: could be XPM */
    RETURN_UNGCPRO (result);

#ifdef HAVE_XPM
  result = try_reading_xpm_bitmap (pi, name, Qunbound, 0,
				   retry_in_mono, no_errors);
#else
  result = Qnil;
#endif /* HAVE_XPM */

  RETURN_UNGCPRO (result);
}

static Lisp_Object
make_image_instance (Lisp_Object inst, Lisp_Object device, int retry_in_mono,
		     int no_errors)
{
  Lisp_Object pi = allocate_image_instance (device);
  struct gcpro gcpro1;
  Lisp_Object type, file, data;

  GCPRO1 (pi);

  /* It better fuckin' be a vector at this point. */
  assert (VECTORP (inst));
  type = vector_data (XVECTOR (inst))[0];

  data = find_keyword_in_vector (inst, Q_data);
  file = find_keyword_in_vector (inst, Q_file);

  if (UNBOUNDP (data) && UNBOUNDP (file))
    abort ();

  if (UNBOUNDP (data))
    {
      if (EQ (type, Qxbm))
	/* #### deal with the mask */
	RETURN_UNGCPRO (make_image_instance_from_xbm_file
	  		(pi, file, no_errors));
#ifdef HAVE_XPM
      if (EQ (type, Qxpm))
	RETURN_UNGCPRO (make_image_instance_from_xpm_file
			(pi, file,
			 find_keyword_in_vector (inst, Q_color_symbols),
			 retry_in_mono, no_errors));
#endif
#ifdef HAVE_XFACE
      if (EQ (type, Qxface))
	{
	  /* #### */
	  warn_when_safe ("Oops, can't handle xface files yet");
	  return Qnil;
	}
#endif
      abort ();
    }

  if (!UNBOUNDP (file))
    XIMAGE_INSTANCE (pi)->filename = file;

  if (EQ (type, Qautodetect))
    RETURN_UNGCPRO (make_image_instance_from_unknown_filename
      		    (pi, data, retry_in_mono, no_errors));

#ifdef HAVE_XPM
  if (EQ (type, Qxpm))
    RETURN_UNGCPRO (make_image_instance_from_xpm_inline
		    (pi, data,
		     find_keyword_in_vector (inst, Q_color_symbols),
		     retry_in_mono, no_errors));
#endif
#ifdef HAVE_XFACE
  if (EQ (type, Qxface))
    RETURN_UNGCPRO (make_image_instance_from_xface
		    (pi, data, no_errors));
#endif
  if (EQ (type, Qxbm))
    /* #### handle mask file */
    RETURN_UNGCPRO (make_image_instance_from_xbm_inline
		    (pi, data,
		     find_keyword_in_vector (inst, Q_mask_data),
		     no_errors)); 

  abort ();
  RETURN_UNGCPRO (Qnil);
}

/* If the INST refers to a file that might contain a pixmap, return
   the full filename.  Otherwise return t if the INST was really
   supposed to refer to a filename (e.g. it was a string ending in .xpm
   or it was a [xpm ...] or [xbm ...] instantiator); otherwise return
   nil. */
static Lisp_Object
potential_pixmap_file_instantiator (Lisp_Object inst)
{
  Lisp_Object file;
  Lisp_Object data;

  assert (VECTORP (inst));
  
  data = find_keyword_in_vector (inst, Q_data);

  if (EQ (vector_data (XVECTOR (inst))[0], Qautodetect))
    return locate_pixmap_file (data);
      
  file = find_keyword_in_vector (inst, Q_file);

  if (!UNBOUNDP (file) && UNBOUNDP (data))
    {
      Lisp_Object retval = locate_pixmap_file (file);
      if (!NILP (retval))
	return retval;
      else
	return Qt; /* should have been file */
    }

  return Qnil;
}

Lisp_Object
x_normalize_image_instantiator (Lisp_Object inst)
{
  Lisp_Object pixmap_file = Qnil, data = Qnil;
  struct gcpro gcpro1, gcpro2, gcpro3;
  Lisp_Object type;
  Lisp_Object *elt;
  Lisp_Object new_elts[13];
  int i = 0;
  
  GCPRO3 (pixmap_file, inst, data);

  pixmap_file = potential_pixmap_file_instantiator (inst);
  if (EQ (pixmap_file, Qt))
    RETURN_UNGCPRO (Qnil);

  elt = vector_data (XVECTOR (inst));
  type = elt[0];

  if (NILP (pixmap_file))
    {
      if (EQ (type, Qautodetect))
	RETURN_UNGCPRO (vector3 (Qstring, Q_data, elt[2]));
      else
	RETURN_UNGCPRO (inst);
    }

  if (EQ (type, Qxbm))
    {
      Lisp_Object mask_file, mask_data;
      data = bitmap_to_lisp_data (pixmap_file);

      if (NILP (data))
	RETURN_UNGCPRO (Qnil);
      mask_file = find_keyword_in_vector (inst, Q_mask_file);
      mask_data = find_keyword_in_vector (inst, Q_mask_data);
      new_elts[i++] = Qxbm;
      new_elts[i++] = Q_file;
      new_elts[i++] = pixmap_file;
      new_elts[i++] = Q_data;
      new_elts[i++] = data;
      if (!UNBOUNDP (mask_file))
	{
	  /* #### still need to handle mask_file better */
	  warn_when_safe ("Oops, can't handle mask files yet");
#if 0
	  new_elts[i++] = Q_mask_file;
	  new_elts[i++] = mask_file;
#endif
	}
      if (!UNBOUNDP (mask_data))
	{
	  new_elts[i++] = Q_mask_data;
	  new_elts[i++] = mask_data;
	}
      RETURN_UNGCPRO (Fvector (i, new_elts));
    }

#ifdef HAVE_XFACE
  if (EQ (type, Qxface))
    {
      /* #### */
      warn_when_safe ("Oops, can't handle xface files yet");
      RETURN_UNGCPRO (Qnil);
    }
#endif

  if (EQ (type, Qautodetect))
    {
      /* #### Apparently some versions of XpmReadFileToData which is
	 called by pixmap_to_lisp_data don't return an error value
	 if the given file is not a valid XPM file.  Instead, they
	 just seg fault.  It is definitely caused by passing a
	 bitmap.  To try and avoid this we check for bitmaps first.  */

      data = bitmap_to_lisp_data (pixmap_file);
      if (!NILP (data))
	{
	  new_elts[i++] = Qxbm;
	  new_elts[i++] = Q_file;
	  new_elts[i++] = pixmap_file;
	  new_elts[i++] = Q_data;
	  new_elts[i++] = data;
	  RETURN_UNGCPRO (Fvector (i, new_elts));
	}

#ifdef HAVE_XPM
      data = pixmap_to_lisp_data (pixmap_file);
      if (!NILP (data))
	{
	  new_elts[i++] = Qxpm;
	  new_elts[i++] = Q_file;
	  new_elts[i++] = pixmap_file;
	  new_elts[i++] = Q_data;
	  new_elts[i++] = data;
	  new_elts[i++] = Q_color_symbols;
	  new_elts[i++] = evaluate_xpm_color_symbols (1);
	  RETURN_UNGCPRO (Fvector (i, new_elts));
	}
#endif

      RETURN_UNGCPRO (Qnil);
    }

#ifdef HAVE_XPM
  if (EQ (type, Qxpm))
    {
      Lisp_Object color_symbols;

      data = pixmap_to_lisp_data (pixmap_file);
      if (!NILP (data))
	{
	  new_elts[i++] = Qxpm;
	  new_elts[i++] = Q_file;
	  new_elts[i++] = pixmap_file;
	  new_elts[i++] = Q_data;
	  new_elts[i++] = data;
	  new_elts[i++] = Q_color_symbols;
	  color_symbols = find_keyword_in_vector (inst, Q_color_symbols);
	  if (UNBOUNDP (color_symbols))
	    color_symbols = evaluate_xpm_color_symbols (1);
	  new_elts[i++] = color_symbols;
	  RETURN_UNGCPRO (Fvector (i, new_elts));
	}

      RETURN_UNGCPRO (Qnil);
    }
#endif /* HAVE_XPM */

  /* 'string, 'formatted-string, 'nothing will not get here because
     potential_pixmap_file_instantiator() will return nil. */
  abort ();
  RETURN_UNGCPRO (Qnil);
}

DEFUN ("make-image-instance", Fmake_image_instance, Smake_image_instance,
       1, 4, 0,
       "Create a new `image-instance' object.\n\
\n\
Image-instance objects encapsulate the way a particular image (pixmap,\n\
etc.) is displayed on a particular device.  In most circumstances, you\n\
do not need to directly create image instances; use a glyph or an image-\n\
specifier instead. (Most functions and data structures that want an image\n\
are designed to take either a glyph or an image-specifier.)")
  (data, device, retry_in_mono, noerror)
  Lisp_Object data, device, retry_in_mono, noerror;
{
  struct gcpro gcpro1;
  int noerr = !NILP (noerror);

  if (noerr && (!DEVICEP (device) || !DEVICE_IS_X (XDEVICE (device))))
    return Qnil;

  XSETDEVICE (device, get_x_device (device));

  if (STRINGP (data))
    {
      Lisp_Object new_data =
	process_image_string_instantiator (data, Qx, noerr);
      if (NILP (new_data))
	{
	  if (noerr)
	    return Qnil;
	  signal_simple_error ("Could not resolve image string", data);
	}
      data = new_data;
    }
  else if (!VECTORP (data))
    {
      if (noerr)
	return Qnil;
      signal_simple_error ("Must be string or vector", data);
    }

  GCPRO1 (data);
  if (!x_valid_image_instantiator_p (data, noerr))
    /* we only get here if NOERROR is set */
    RETURN_UNGCPRO (Qnil);

  RETURN_UNGCPRO (make_image_instance (data, device, !NILP (retry_in_mono),
				       noerr));
}

DEFUN ("image-instance-p", Fimage_instance_p, Simage_instance_p, 1, 1, 0,
       "Return non-nil if OBJECT is an image instance.")
  (object)
  Lisp_Object object;
{
  return (IMAGE_INSTANCEP (object) ? Qt : Qnil);
}

DEFUN ("set-image-instance-hotspot", Fset_image_instance_hotspot,
       Sset_image_instance_hotspot,
       3, 3, 0,
       "Set the image instance's hotspot.\n\
This is a point relative to the origin of the pixmap.  When a pixmap is\n\
used as a cursor or similar pointing indicator, the hotspot is the point\n\
on the pixmap that sits over the location that the pointer points to.\n\
This is, for example, the tip of the arrow or the center of the crosshairs.")
     (image_instance, x, y)
     Lisp_Object image_instance, x, y;
{
  struct Lisp_Image_Instance *p;

  CHECK_IMAGE_INSTANCE (image_instance, 0);
  CHECK_INT (x, 0);
  CHECK_INT (y, 0);
  p = XIMAGE_INSTANCE (image_instance);
  p->x = XINT (x);
  p->y = XINT (y);
  return Qnil;
}

DEFUN ("image-instance-hotspot-x", Fimage_instance_hotspot_x,
       Simage_instance_hotspot_x, 1, 1, 0,
       "Return the X coordinate of the image instance's hotspot.\n\
See `set-image-instance-hotspot'.")
     (image_instance)
     Lisp_Object image_instance;
{
  CHECK_IMAGE_INSTANCE (image_instance, 0);
  return make_number (XIMAGE_INSTANCE (image_instance)->x);
}

DEFUN ("image-instance-hotspot-y", Fimage_instance_hotspot_y,
       Simage_instance_hotspot_y, 1, 1, 0,
       "Return the Y coordinate of the image instance's hotspot.\n\
See `set-image-instance-hotspot'.")
     (image_instance)
     Lisp_Object image_instance;
{
  CHECK_IMAGE_INSTANCE (image_instance, 0);
  return make_number (XIMAGE_INSTANCE (image_instance)->y);
}

DEFUN ("image-instance-depth", Fimage_instance_depth,
       Simage_instance_depth, 1, 1, 0,
       "Return the depth of the image instance.\n\
This is 0 for a bitmap, or a positive integer for a pixmap.")
     (image_instance)
     Lisp_Object image_instance;
{
  CHECK_IMAGE_INSTANCE (image_instance, 0);
  return (make_number (XIMAGE_INSTANCE (image_instance)->depth));
}

DEFUN ("image-instance-height", Fimage_instance_height,
       Simage_instance_height, 1, 1, 0,
       "Return the height of the image instance, in pixels.")
     (image_instance)
     Lisp_Object image_instance;
{
  CHECK_IMAGE_INSTANCE (image_instance, 0);
  return (make_number (XIMAGE_INSTANCE (image_instance)->height));
}

DEFUN ("image-instance-width", Fimage_instance_width,
       Simage_instance_width, 1, 1, 0,
       "Return the width of the image instance, in pixels.")
     (image_instance)
     Lisp_Object image_instance;
{
  CHECK_IMAGE_INSTANCE (image_instance, 0);
  return (make_number (XIMAGE_INSTANCE (image_instance)->width));
}

DEFUN ("image-instance-file-name", Fimage_instance_file_name,
       Simage_instance_file_name, 1, 1, 0,
      "Return the file name from which the given image instance was read,\n\
or nil if the image instance was created from Lisp data (the lisp data is\n\
not retained, since it usually won't be needed again and might be quite\n\
large).")
  (image_instance)
  Lisp_Object image_instance;
{
  CHECK_IMAGE_INSTANCE (image_instance, 0);
  return (XIMAGE_INSTANCE (image_instance)->filename);
}

/* #### This function could fuck with pixmap caches.  Need to rethink. */

DEFUN ("colorize-image-instance", Fcolorize_image_instance,
       Scolorize_image_instance, 3, 3, 0,
       "Make the image instance be displayed in the given colors.\n\
Image instances come in two varieties: bitmaps, which are 1 bit deep which\n\
are rendered in the prevailing foreground and background colors; and\n\
pixmaps, which are of arbitrary depth (including 1) and which have the\n\
colors explicitly specified.  This function converts a bitmap to a pixmap.\n\
If the image instance was a pixmap already, nothing is done (and nil is\n\
returned).  Otherwise t is returned.")
  (image_instance, foreground, background)
  Lisp_Object image_instance, foreground, background;
{
  struct Lisp_Image_Instance *p;
  CHECK_IMAGE_INSTANCE (image_instance, 0);
  CHECK_COLOR_INSTANCE (foreground, 0);
  CHECK_COLOR_INSTANCE (background, 0);
  p = XIMAGE_INSTANCE (image_instance);
  if (p->depth > 0) return Qnil;
  {
    Display *dpy = DEVICE_X_DISPLAY (XDEVICE (p->device));
    Screen *scr = DefaultScreenOfDisplay (dpy);
    Dimension d = DefaultDepthOfScreen (scr);
    Colormap cmap = DefaultColormapOfScreen (scr);
    Pixmap new = XCreatePixmap (dpy, RootWindowOfScreen (scr),
				p->width, p->height, d);
    XColor color;
    XGCValues gcv;
    GC gc;
    /* Duplicate the pixel values so that we still have a lock on them if
       the pixels we were passed are later freed. */
    color = COLOR_INSTANCE_X_COLOR (XCOLOR_INSTANCE (foreground));
    if (! XAllocColor (dpy, cmap, &color)) abort ();
    gcv.foreground = color.pixel;
    color = COLOR_INSTANCE_X_COLOR (XCOLOR_INSTANCE (background));
    if (! XAllocColor (dpy, cmap, &color)) abort ();
    gcv.background = color.pixel;
    gc = XCreateGC (dpy, new, GCBackground|GCForeground, &gcv);
    XCopyPlane (dpy, p->pixmap, new, gc, 0, 0, p->width, p->height, 0, 0, 1);
    XFreeGC (dpy, gc);
    XFreePixmap (dpy, p->pixmap);
    p->pixmap = new;
    p->depth = d;
  }
  return Qt;
}


/************************************************************************/
/*                                cursors                               */
/************************************************************************/

/* #### this shit needs overhauling and specifierifying */

Lisp_Object Qcursorp;
static Lisp_Object mark_cursor (Lisp_Object, void (*) (Lisp_Object));
static void print_cursor (Lisp_Object, Lisp_Object, int);
static void finalize_cursor (void *, int);
static int cursor_equal (Lisp_Object, Lisp_Object, int depth);
static unsigned long cursor_hash (Lisp_Object obj, int depth);
DEFINE_LRECORD_IMPLEMENTATION ("cursor", cursor,
			       mark_cursor, print_cursor, finalize_cursor,
			       cursor_equal, cursor_hash, struct Lisp_Cursor);

static Lisp_Object
mark_cursor (Lisp_Object obj, void (*markobj) (Lisp_Object))
{
  struct Lisp_Cursor *c = XCURSOR (obj);
  ((markobj) (c->fg));
  ((markobj) (c->bg));
  ((markobj) (c->name));
  return c->device;
}

static void
print_cursor (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
{
  char buf[200];
  struct Lisp_Cursor *c = XCURSOR (obj);
  if (print_readably)
    error ("printing unreadable object #<cursor 0x%x>",
	   c->header.uid);

  write_c_string ("#<cursor ", printcharfun);
  print_internal (c->name, printcharfun, 1);
  if (!NILP (c->fg))
    {
      write_c_string (" (", printcharfun);
      print_internal (XCOLOR_INSTANCE (c->fg)->name, printcharfun, 0);
      write_c_string ("/", printcharfun);
      print_internal (XCOLOR_INSTANCE (c->bg)->name, printcharfun, 0);
      write_c_string (")", printcharfun);
    }
  sprintf (buf, " 0x%x>", c->header.uid);
  /* #### should print the device */
  write_c_string (buf, printcharfun);
}

static void
finalize_cursor (void *header, int for_disksave)
{
  struct Lisp_Cursor *c = (struct Lisp_Cursor *) header;
  if (for_disksave) finalose (c);
  if (c->cursor)
    {
      XFreeCursor (DEVICE_X_DISPLAY (XDEVICE (c->device)), c->cursor);
      c->cursor = 0;
    }
}

/* Cursors are equal if their names are equal. */
static int
cursor_equal (Lisp_Object o1, Lisp_Object o2, int depth)
{
  return (internal_equal (XCURSOR (o1)->name, XCURSOR (o2)->name, depth + 1));
}

static unsigned long
cursor_hash (Lisp_Object obj, int depth)
{
  return internal_hash (XCURSOR (obj)->name, depth + 1);
}

#ifdef USE_XMU_CURSORS

/* XmuCvtStringToCursor is bogus in the following ways:

   - When it can't convert the given string to a real cursor, it will
     sometimes return a "success" value, after triggering a BadPixmap
     error.  It then gives you a cursor that will itself generate BadCursor
     errors.  So we install this error handler to catch/notice the X error
     and take that as meaning "couldn't convert."

   - When you tell it to find a cursor file that doesn't exist, it prints
     an error message on stderr.  You can't make it not do that.

   - Also, using Xmu means we can't properly hack Lisp_Image_Instance
     objects, or XPM files, or $XBMLANGPATH.
 */

static int XmuCvtStringToCursor_got_error;
static int XmuCvtStringToCursor_error_handler (Display *dpy,
					       XErrorEvent *error)
{
  XmuCvtStringToCursor_got_error = 1;
  return 0;
}


static Cursor 
make_cursor_1 (Lisp_Object device, Lisp_Object name)
{
  /* Other version of this function can GC */
  int (*old_handler) ();
  XrmValue arg, from, to;
  Cardinal nargs = 1;
  Cursor cursor;
  Screen *xs = LISP_DEVICE_TO_X_SCREEN (device);

  if (IMAGE_INSTANCEP (name))
    error ("no support for converting image instances to cursors.");
  CHECK_STRING (name, 0);

  arg.addr = (XtPointer) &xs;
  arg.size = sizeof (Screen *);
  from.addr = (XtPointer) string_ext_data (XSTRING (name));
  from.size = string_ext_length (XSTRING (name));
  to.addr = 0;
  to.size = 0;
  XSync (DisplayOfScreen (xs), 0);
  XmuCvtStringToCursor_got_error = 0;
  old_handler = XSetErrorHandler (XmuCvtStringToCursor_error_handler);
  /* #### This fucker unconditionally writes an error message on stderr
     if it can't convert the cursor!  LOSERS!! */
  XmuCvtStringToCursor (&arg, &nargs, &from, &to);
  XSync (DisplayOfScreen (xs), 0);
  XSetErrorHandler (old_handler);
  if (XmuCvtStringToCursor_got_error)
    cursor = 0;
  else if (to.addr)
    cursor = *((Cursor *) to.addr);
  else
    cursor = 0;

  return cursor;
}

#else /* !USE_XMU_CURSORS */

/* Duplicate the behavior of XmuCvtStringToCursor() to bypass its bogusness. */

static int XLoadFont_got_error;
static int XLoadFont_error_handler (Display *dpy, XErrorEvent *xerror)
{
  XLoadFont_got_error = 1;
  return 0;
}

static Font
safe_XLoadFont (Display *dpy, char *name)
{
  Font font;
  int (*old_handler) ();
  XLoadFont_got_error = 0;
  XSync (dpy, 0);
  old_handler = XSetErrorHandler (XLoadFont_error_handler);
  font = XLoadFont (dpy, name);
  XSync (dpy, 0);
  XSetErrorHandler (old_handler);
  if (XLoadFont_got_error) return 0;
  return font;
}

/* Check that this server supports cursors of this size. */
static void
check_pointer_sizes (Screen *xs, unsigned int width, unsigned int height,
		     Lisp_Object name, Lisp_Object object)
{
  unsigned int best_width, best_height;
  if (! XQueryBestCursor (DisplayOfScreen (xs), RootWindowOfScreen (xs),
			  width, height, &best_width, &best_height))
    /* #### What does it mean when XQueryBestCursor() returns 0?
       I can't find that documented anywhere. */
    best_width = best_height = 0;

  if (width > best_width || height > best_height)
    {
      char buf [255];
      sprintf (buf, "cursor too large (%dx%d): "
	       "server requires %dx%d or smaller",
	       width, height, best_width, best_height);
      signal_error (Qerror, list3 (build_string (buf), name, object));
    }
}

static Cursor 
make_cursor_1 (Lisp_Object device, Lisp_Object name)
{
  /* This function can GC */
  Screen *xs = LISP_DEVICE_TO_X_SCREEN (device);
  Display *dpy = DisplayOfScreen (xs);
  XColor fg, bg;
  Cursor cursor;
  int i;

  fg.pixel = bg.pixel = 0;
  fg.red = fg.green = fg.blue = 0;
  bg.red = bg.green = bg.blue = ~0;

  if (STRINGP (name) &&
      !strncmp ("FONT ", (char *) string_data (XSTRING (name)), 5))
    {
      Font source, mask;
      char source_name [MAXPATHLEN], mask_name [MAXPATHLEN], dummy;
      int source_char, mask_char;
      int count = sscanf ((char *) string_data (XSTRING (name)),
			  "FONT %s %d %s %d %c",
			  source_name, &source_char,
			  mask_name, &mask_char, &dummy);
      /* Allow "%s %d %d" as well... */
      if (count == 3 && (1 == sscanf (mask_name, "%d %c", &mask_char, &dummy)))
	count = 4, mask_name[0] = 0;

      if (count != 2 && count != 4)
	signal_simple_error ("invalid cursor specification", name);
      source = safe_XLoadFont (dpy, source_name);
      if (! source)
	signal_simple_error_2 ("couldn't load font",
			       build_string (source_name),
			       name);
      if (count == 2)
	mask = 0;
      else if (! mask_name[0])
	mask = source;
      else
	{
	  mask = safe_XLoadFont (dpy, mask_name);
	  if (! mask) /* continuable */
	    Fsignal (Qerror, list3 (build_string ("couldn't load font"),
				    build_string (mask_name), name));
	}
      if (! mask) mask_char = 0;

      /* #### call XQueryTextExtents() and check_pointer_sizes() here. */

      cursor = XCreateGlyphCursor (dpy, source, mask, source_char, mask_char,
				   &fg, &bg);
      XUnloadFont (dpy, source);
      if (mask && mask != source) XUnloadFont (dpy, mask);
    }

  else if (STRINGP (name) &&
	   (i = XmuCursorNameToIndex (string_ext_data (XSTRING (name)))) != -1)
    {
      cursor = XCreateFontCursor (dpy, i);
    }

  else
    {
      struct gcpro gcpro1, gcpro2, gcpro3;
      Lisp_Object lsource;
      Lisp_Object lmask = Qnil;
      Lisp_Object mask_file = Qnil;
      Pixmap source, mask;

      GCPRO3 (lsource, lmask, mask_file);

      if (IMAGE_INSTANCEP (name))
	lsource = name;
      else if (GLYPHP (name))
	lsource = glyph_image_instance (name, device, 0);
      else
	/* #### We may not want this to error later on. */
	lsource = Fmake_image_instance (name, device, Qt, Qnil);

      if (!IMAGE_INSTANCEP (lsource))
	signal_simple_error ("Could not obtain image instance", name);

      source = XIMAGE_INSTANCE (lsource)->pixmap;
      mask = XIMAGE_INSTANCE (lsource)->mask;

      if (XIMAGE_INSTANCE (lsource)->depth > 1)
	signal_error (Qerror,
		      list3 (build_string ("cursor image instances must be 1 plane"),
			     name, lsource));
      if (!mask && STRINGP (name))
	{
	  mask_file =
	    locate_pixmap_file (concat2 (name, build_string ("Mask")));
	  if (NILP (mask_file))
	    mask_file =
	      locate_pixmap_file (concat2 (name, build_string ("msk")));
	  if (!NILP (mask_file))
	    {
	      /* #### We may not want this to error later on. */
	      lmask = Fmake_image_instance (mask_file, device, Qt, Qnil);
	      if (!IMAGE_INSTANCEP (lmask))
		signal_simple_error
		  ("Could not obtain mask image instance", lmask);
	      if (XIMAGE_INSTANCE (lmask)->depth != 0)
		signal_simple_error_2 ("mask must be 1 bit deep",
				       mask_file, lmask);
	      mask = XIMAGE_INSTANCE (lmask)->pixmap;
	      mask_file = Qnil;
	    }
	}

      check_pointer_sizes (xs,
			   XIMAGE_INSTANCE (lsource)->width,
			   XIMAGE_INSTANCE (lsource)->height,
			   name, lsource);

      /* If the loaded pixmap has colors allocated (meaning it came from an
	 XPM file), then use those as the default colors for the cursor we
	 create.  Otherwise, default to black and white.
       */
      if (XIMAGE_INSTANCE (lsource)->npixels >= 2)
	{
	  int npixels = XIMAGE_INSTANCE (lsource)->npixels;
	  unsigned long *pixels = XIMAGE_INSTANCE (lsource)->pixels;

	  /* With an XBM file, it's obvious which bit is foreground and which
	     is background, or rather, it's implicit: in an XBM file, a 1 bit
	     is foreground, and a 0 bit is background.

	     XCreatePixmapCursor() assumes this property of the pixmap it is
	     called with as well; the `foreground' color argument is used for
	     the 1 bits.

	     With an XPM file, it's tricker, since the elements of the pixmap
	     don't represent FG and BG, but are actual pixel values.  So we
	     need to figure out which of those pixels is the foreground color
	     and which is the background.  We do it by comparing RGB and
	     assuming that the darker color is the foreground.  This works
	     with the result of xbmtopbm|ppmtoxpm, at least.

	     It might be nice if there was some way to tag the colors in the
	     XPM file with whether they are the foreground - perhaps with
	     logical color names somehow?

	     Once we have decided which color is the foreground, we need to
	     ensure that that color corresponds to a `1' bit in the Pixmap.
	     The XPM library wrote into the (1-bit) pixmap with XPutPixel,
	     which will ignore all but the least significant bit.

	     This means that a 1 bit in the image corresponds to `fg' only if
	     `fg.pixel' is odd.

	     (This also means that the image will be all the same color if
	     both `fg' and `bg' are odd or even, but we can safely assume
	     that that won't happen if the XPM file is sensible I think.)

	     The desired result is that the image use `1' to represent the
	     foreground color, and `0' to represent the background color.
	     So, we may need to invert the image to accomplish this; we invert
	     if fg is odd. (Remember that WhitePixel and BlackPixel are not
	     necessarily 1 and 0 respectively, though I think it might be safe
	     to assume that one of them is always 1 and the other is always 0.
	     We also pretty much need to assume that one is even and the other
	     is odd.)
	   */

	  fg.pixel = pixels [0];	/* pick a pixel at random. */
	  bg.pixel = fg.pixel;
	  for (i = 1; i < npixels; i++)	/* Look for an "other" pixel value. */
	    {
	      bg.pixel = pixels [i];
	      if (fg.pixel != bg.pixel) break;
	    }

	  /* If (fg.pixel == bg.pixel) then probably something has gone wrong,
	     but I don't think signalling an error would be appropriate. */

	  XQueryColor (DisplayOfScreen(xs), DefaultColormapOfScreen(xs), &fg);
	  XQueryColor (DisplayOfScreen(xs), DefaultColormapOfScreen(xs), &bg);

	  /* If the foreground is lighter than the background, swap them.
	     (This occurs semi-randomly, depending on the ordering of the
	     color list in the XPM file.)
	   */
	  {
	    unsigned short fg_total = ((fg.red / 3) + (fg.green / 3)
				       + (fg.blue / 3));
	    unsigned short bg_total = ((bg.red / 3) + (bg.green / 3)
				       + (bg.blue / 3));
	      if (fg_total > bg_total)
		{
		  XColor swap;
		  swap = fg;
		  fg = bg;
		  bg = swap;
		}
	  }

	  /* If the fg pixel corresponds to a `0' in the bitmap, invert it.
	     (This occurs (only?) on servers with Black=0, White=1.)
	   */
	  if ((fg.pixel & 1) == 0)
	    {
	      XGCValues gcv;
	      GC gc;
	      gcv.function = GXxor;
	      gcv.foreground = 1;
	      gc = XCreateGC (dpy, source, (GCFunction | GCForeground), &gcv);
	      XFillRectangle (dpy, source, gc, 0, 0,
			      XIMAGE_INSTANCE (lsource)->width,
			      XIMAGE_INSTANCE (lsource)->height);
	      XFreeGC (dpy, gc);
	    }
	}

      cursor = XCreatePixmapCursor (dpy, source, mask, &fg, &bg,
				    XIMAGE_INSTANCE (lsource)->x,
				    XIMAGE_INSTANCE (lsource)->y);
      UNGCPRO; /* can now collect and free `lsource', `lmask', and Pixmaps. */
    }
  return cursor;
}

#endif /* !USE_XMU_CURSORS */


DEFUN ("make-cursor", Fmake_cursor, Smake_cursor, 1, 4, 0,
       "Creates a new `cursor' object of the specified name.\n\
The optional second and third arguments are the foreground and background\n\
 colors.  They may be color name strings or `pixel' objects.\n\
The optional fourth argument is the device on which to allocate the cursor\n\
 (defaults to the selected device).\n\
This allocates a new cursor in the X server, and signals an error if the\n\
 cursor is unknown or cannot be allocated.\n\
\n\
A cursor name can take many different forms.  It can be:\n\
 - any of the standard cursor names from appendix B of the Xlib manual\n\
   (also known as the file <X11/cursorfont.h>) minus the XC_ prefix;\n\
 - the name of a font, and glyph index into it of the form\n\
   \"FONT fontname index [[mask-font] mask-index]\";\n\
 - the name of a bitmap or pixmap file;\n\
 - or an image instance object, as returned by `make-image-instance'.\n\
\n\
If it is an image instance or pixmap file, and that pixmap comes with a\n\
 mask, then that mask will be used.  If it is an image instance, it must\n\
 have only one plane, since X cursors may only have two colors.  If it is a\n\
 pixmap file, then the file will be read in monochrome.\n\
\n\
If it is a bitmap file, and if a bitmap file whose name is the name of the\n\
 cursor with \"msk\" or \"Mask\" appended exists, then that second bitmap\n\
 will be used as the mask.  For example, a pair of files might be named\n\
 \"cursor.xbm\" and \"cursor.xbmmsk\".\n\
\n\
The returned object is a normal, first-class lisp object.  The way you\n\
`deallocate' the cursor is the way you deallocate any other lisp object:\n\
you drop all pointers to it and allow it to be garbage collected.  When\n\
these objects are GCed, the underlying X data is deallocated as well.")
  (name, fg, bg, device)
  Lisp_Object name, fg, bg, device;
{
  /* This function can GC */
  Screen *xs;
  Cursor cursor;

  XSETDEVICE (device, get_x_device (device));
  xs = LISP_DEVICE_TO_X_SCREEN (device);

  if ((NILP (fg)) != (NILP (bg)))
    error ("must specify both foreground and background, or neither.");

  if (STRINGP (fg))
    fg = Fmake_color_instance (fg, device, Qnil);
  else if (!NILP (fg) && !COLOR_INSTANCEP (fg))
    CHECK_STRING (fg, 0);

  if (STRINGP (bg))
    bg = Fmake_color_instance (bg, device, Qnil);
  else if (!NILP (bg) && !COLOR_INSTANCEP (bg))
    CHECK_STRING (bg, 0);

  cursor = make_cursor_1 (device, name);

  if (! cursor)
    signal_simple_error ("unknown cursor", name);

  /* Got the cursor, now color it in.
     (Either both are specified or neither.) */
  if (!NILP (fg))
    {
      XColor xbg, xfg;

      xbg = COLOR_INSTANCE_X_COLOR (XCOLOR_INSTANCE (bg));
      xfg = COLOR_INSTANCE_X_COLOR (XCOLOR_INSTANCE (fg));

      XRecolorCursor (DisplayOfScreen (xs), cursor,
		      &xfg, &xbg);
    }
  
  /* Now make the lisp object. */
  {
    struct Lisp_Cursor *c = alloc_lcrecord (sizeof (struct Lisp_Cursor),
					    lrecord_cursor);
    Lisp_Object val;
    c->device = device;
    c->name = name;
    c->cursor = cursor;
    c->fg = fg;
    c->bg = bg;
    XSETCURSOR (val, c);
    return val;
  }
}

DEFUN ("cursorp", Fcursorp, Scursorp, 1, 1, 0,
       "Return non-nil if OBJECT is a cursor.")
  (object)
  Lisp_Object object;
{
  return (CURSORP (object) ? Qt : Qnil);
}

DEFUN ("cursor-name", Fcursor_name, Scursor_name, 1, 1, 0,
       "Return the name used to allocate the given cursor.")
  (cursor)
  Lisp_Object cursor;
{
  CHECK_CURSOR (cursor, 0);
  return (XCURSOR (cursor)->name);
}

DEFUN ("cursor-foreground", Fcursor_foreground, Scursor_foreground, 1, 1, 0,
   "Return the foreground color of the given cursor, or nil if unspecified.")
  (cursor)
  Lisp_Object cursor;
{
  CHECK_CURSOR (cursor, 0);
  return (XCURSOR (cursor)->fg);
}

DEFUN ("cursor-background", Fcursor_background, Scursor_background, 1, 1, 0,
   "Return the background color of the given cursor, or nil if unspecified.")
  (cursor)
  Lisp_Object cursor;
{
  CHECK_CURSOR (cursor, 0);
  return (XCURSOR (cursor)->bg);
}


/************************************************************************/
/*                               subwindows                             */
/************************************************************************/

Lisp_Object Qsubwindowp;
static Lisp_Object mark_subwindow (Lisp_Object, void (*) (Lisp_Object));
static void print_subwindow (Lisp_Object, Lisp_Object, int);
static void finalize_subwindow (void *, int);
static int subwindow_equal (Lisp_Object o1, Lisp_Object o2, int depth);
static unsigned long subwindow_hash (Lisp_Object obj, int depth);
DEFINE_LRECORD_IMPLEMENTATION ("subwindow", subwindow,
			       mark_subwindow, print_subwindow,
			       finalize_subwindow, subwindow_equal,
			       subwindow_hash, struct Lisp_Subwindow);

static Lisp_Object
mark_subwindow (Lisp_Object obj, void (*markobj) (Lisp_Object))
{
  struct Lisp_Subwindow *sw = XSUBWINDOW (obj);
  return sw->frame;
}

static void
print_subwindow (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
{
  char buf[100];
  struct Lisp_Subwindow *sw = XSUBWINDOW (obj);
  struct frame *frm = XFRAME (sw->frame);

  if (print_readably)
    error ("printing unreadable object #<subwindow 0x%x>",
	   sw->header.uid);

  write_c_string ("#<subwindow", printcharfun);
  sprintf (buf, " %dx%d", sw->width, sw->height);
  write_c_string (buf, printcharfun);

  /* This is stolen from frame.c.  Subwindows are strange in that they
     are specific to a particular frame so we want to print in their
     description what that frame is. */
  
  write_c_string (" on #<", printcharfun);
  if (!FRAME_LIVE_P (frm))
    write_c_string ("dead", printcharfun);
  else if (FRAME_IS_TTY (frm))
    write_c_string ("tty", printcharfun);
  else if (FRAME_IS_X (frm))
    write_c_string ("x", printcharfun);
  else
    write_c_string ("UNKNOWN", printcharfun);
  write_c_string ("-frame ", printcharfun);
  print_internal (frm->name, printcharfun, 1);
  sprintf (buf, " 0x%x>", frm->header.uid);
  write_c_string (buf, printcharfun);

  sprintf (buf, ") 0x%x>", sw->header.uid);
  write_c_string (buf, printcharfun);
}

static void
finalize_subwindow (void *header, int for_disksave)
{
  struct Lisp_Subwindow *sw = (struct Lisp_Subwindow *) header;
  if (for_disksave) finalose (sw);
  if (sw->subwindow)
    {
      XDestroyWindow (DisplayOfScreen (sw->xscreen), sw->subwindow);
      sw->subwindow = 0;
    }
}

/* subwindows are equal iff they have the same window XID */
static int
subwindow_equal (Lisp_Object o1, Lisp_Object o2, int depth)
{
  return (XSUBWINDOW (o1)->subwindow == XSUBWINDOW (o2)->subwindow);
}

static unsigned long
subwindow_hash (Lisp_Object obj, int depth)
{
  return XSUBWINDOW (obj)->subwindow;
}

/* #### PROBLEM: The display routines assume that the glyph is only
 being displayed in one buffer.  If it is in two different buffers
 which are both being displayed simultaneously you will lose big time.
 This can be dealt with in the new redisplay. */

/* #### These are completely un-re-implemented in 19.12.  Get it done
   for 19.13. */

DEFUN ("make-subwindow", Fmake_subwindow, Smake_subwindow,
       0, 3, 0,
       "Creates a new `x-window' object of size WIDTH x HEIGHT.\n\
The default is a window of size 1x1, which is also the minimum allowed\n\
window size.  Subwindows are per-frame.  A buffer being shown in two\n\
different frames will only display a subwindow glyph in the frame in\n\
which it was actually created.  If two windows on the same frame are\n\
displaying the buffer then the most recently used window will actually\n\
display the window.  If the frame is not specified, the selected frame\n\
is used.")
  (width, height, frame)
  Lisp_Object width, height, frame;
{
  Display *dpy;
  Screen *xs;
  Window pw;
  struct frame *f;
  unsigned int iw, ih;
  XSetWindowAttributes xswa;
  Mask valueMask = 0;

  error ("subwindows are not functional in 19.12; they will be in 19.13");

  f = get_x_frame (frame);

  xs = LISP_DEVICE_TO_X_SCREEN (FRAME_DEVICE (f));
  dpy = DisplayOfScreen (xs);
  pw = XtWindow (FRAME_X_TEXT_WIDGET (f));

  if (NILP (width))
    iw = 1;
  else
    {
      CHECK_INT (width, 0);
      iw = XINT (width);
      if (iw < 1) iw = 1;
    }
  if (NILP (height))
    ih = 1;
  else
    {
      CHECK_INT (height, 0);
      ih = XINT (height);
      if (ih < 1) ih = 1;
    }

  {
    struct Lisp_Subwindow *sw = alloc_lcrecord (sizeof (struct Lisp_Subwindow),
						lrecord_subwindow);
    Lisp_Object val;
    sw->frame = frame;
    sw->xscreen = xs;
    sw->parent_window = pw;
    sw->height = ih;
    sw->width = iw;

    xswa.backing_store = Always;
    valueMask |= CWBackingStore;

    xswa.colormap = DefaultColormapOfScreen (xs);
    valueMask |= CWColormap;

    sw->subwindow = XCreateWindow (dpy, pw, 0, 0, iw, ih, 0, CopyFromParent,
				   InputOutput, CopyFromParent, valueMask,
				   &xswa);

    XSETSUBWINDOW (val, sw);
    return val;
  }
}

/* #### Should this function exist? */
DEFUN ("change-subwindow-property", Fchange_subwindow_property,
       Schange_subwindow_property, 3, 3, 0,
       "For the given SUBWINDOW, set PROPERTY to DATA, which is a string.")
  (subwindow, property, data)
  Lisp_Object subwindow, property, data;
{
  Atom property_atom;
  struct Lisp_Subwindow *sw;
  Display *dpy;

  CHECK_SUBWINDOW (subwindow, 0);
  CHECK_STRING (property, 0);
  CHECK_STRING (data, 0);

  sw = XSUBWINDOW (subwindow);
  dpy = DisplayOfScreen (LISP_DEVICE_TO_X_SCREEN
			 (FRAME_DEVICE (XFRAME (sw->frame))));

  property_atom = XInternAtom (dpy, (char *) string_data (XSTRING (property)),
			       False);
  XChangeProperty (dpy, sw->subwindow, property_atom, XA_STRING, 8,
		   PropModeReplace, string_data (XSTRING (data)),
		   string_length (XSTRING (data)));

  return (property);
}

DEFUN ("subwindowp", Fsubwindowp, Ssubwindowp, 1, 1, 0,
       "Return non-nil if OBJECT is a subwindow.")
  (object)
  Lisp_Object object;
{
  return (SUBWINDOWP (object) ? Qt : Qnil);
}

DEFUN ("subwindow-width", Fsubwindow_width, Ssubwindow_width,
       1, 1, 0,
       "Width of SUBWINDOW.")
  (subwindow)
  Lisp_Object subwindow;
{
  CHECK_SUBWINDOW (subwindow, 0);
  return (make_number (XSUBWINDOW (subwindow)->width));
}

DEFUN ("subwindow-height", Fsubwindow_height, Ssubwindow_height,
       1, 1, 0,
       "Height of SUBWINDOW.")
  (subwindow)
  Lisp_Object subwindow;
{
  CHECK_SUBWINDOW (subwindow, 0);
  return (make_number (XSUBWINDOW (subwindow)->height));
}

DEFUN ("subwindow-xid", Fsubwindow_xid, Ssubwindow_xid, 1, 1, 0,
       "Return the xid of SUBWINDOW as a number.")
  (subwindow)
  Lisp_Object subwindow;
{
  CHECK_SUBWINDOW (subwindow, 0);
  return (make_number (XSUBWINDOW (subwindow)->subwindow));
}

DEFUN ("resize-subwindow", Fresize_subwindow, Sresize_subwindow,
       1, 3, 0,
  "Resize SUBWINDOW to WIDTH x HEIGHT.\n\
If a value is nil that parameter is not changed.")
  (subwindow, width, height)
  Lisp_Object subwindow, width, height;
{
  int neww, newh;
  struct Lisp_Subwindow *sw;

  CHECK_SUBWINDOW (subwindow, 0);
  sw = XSUBWINDOW (subwindow);

  if (NILP (width))
    neww = sw->width;
  else
    neww = XINT (width);

  if (NILP (height))
    newh = sw->height;
  else
    newh = XINT (height);

  XResizeWindow (DisplayOfScreen (sw->xscreen), sw->subwindow, neww, newh);

  sw->height = newh;
  sw->width = neww;

  return subwindow;
}

DEFUN ("force-subwindow-map", Fforce_subwindow_map,
       Sforce_subwindow_map, 1, 1, 0,
  "Generate a Map event for SUBWINDOW.")
     (subwindow)
     Lisp_Object subwindow;
{
  CHECK_SUBWINDOW (subwindow, 0);

  XMapWindow (DisplayOfScreen (XSUBWINDOW (subwindow)->xscreen),
	      XSUBWINDOW (subwindow)->subwindow);

  return subwindow;
}

#define BUILD_GLYPH_INST(variable, name)			\
  Fadd_spec_to_specifier					\
    (GLYPH_IMAGE (XGLYPH (variable)),				\
     vector3 (Qxbm, Q_data,					\
	      list3 (make_number (name##_width),		\
		     make_number (name##_height),		\
		     make_ext_string ((char *) name##_bits,	\
				      sizeof (name##_bits)))),	\
     Qglobal, Qx, Qnil)

void
syms_of_glyphs_x (void)
{
  defsymbol (&Qcursorp, "cursorp");
  defsubr (&Smake_cursor);
  defsubr (&Scursorp);
  defsubr (&Scursor_name);
  defsubr (&Scursor_foreground);
  defsubr (&Scursor_background);

  defsymbol (&Qimage_instancep, "image-instance-p");
  defsubr (&Smake_image_instance);
  defsubr (&Simage_instance_p);
  defsubr (&Sset_image_instance_hotspot);
  defsubr (&Simage_instance_hotspot_x);
  defsubr (&Simage_instance_hotspot_y);
  defsubr (&Simage_instance_depth);
  defsubr (&Simage_instance_height);
  defsubr (&Simage_instance_width);
  defsubr (&Simage_instance_file_name);
  defsubr (&Scolorize_image_instance);

  defsymbol (&Qsubwindowp, "subwindowp");
  defsubr (&Smake_subwindow);
  defsubr (&Schange_subwindow_property);
  defsubr (&Ssubwindowp);
  defsubr (&Ssubwindow_width);
  defsubr (&Ssubwindow_height);
  defsubr (&Ssubwindow_xid);
  defsubr (&Sresize_subwindow);
  defsubr (&Sforce_subwindow_map);

  defsymbol (&Q_mask_file, ":mask-file");
    Fset (Q_mask_file, Q_mask_file);
  defsymbol (&Q_mask_data, ":mask-data");
    Fset (Q_mask_data, Q_mask_data);
#ifdef HAVE_XPM
  defsymbol (&Q_color_symbols, ":color-symbols");
    Fset (Q_color_symbols, Q_color_symbols);
#endif

#ifdef HAVE_XPM
  defsymbol (&Qxpm, "xpm");
  Fprovide (Qxpm);
#endif 
#ifdef HAVE_XFACE
  defsymbol (&Qxface, "xface");
  Fprovide (Qxface);
#endif 

  defsymbol (&Qxbm, "xbm");

  DEFVAR_LISP ("x-bitmap-file-path", &Vx_bitmap_file_path,
       "A list of the directories in which X bitmap files may be found.\n\
If nil, this is initialized from the \"*bitmapFilePath\" resource.\n\
This is used by the `make-image-instance' function (however, note that if\n\
the environment variable XBMLANGPATH is set, it is consulted first).");
  Vx_bitmap_file_path = Qnil;

#ifdef HAVE_XPM
  DEFVAR_LISP ("xpm-color-symbols", &Vxpm_color_symbols,
       "Definitions of logical color-names used when reading XPM files.\n\
Elements of this list should be of the form (COLOR-NAME FORM-TO-EVALUATE).\n\
The COLOR-NAME should be a string, which is the name of the color to define;\n\
the FORM should evaluate to a `color' specifier object, or a string to be\n\
passed to `make-color-instance'.  If a loaded XPM file references a symbolic\n\
color called COLOR-NAME, it will display as the computed color instead.\n\
\n\
The default value of this variable defines the logical color names\n\
\"foreground\" and \"background\" to be the colors of the `default' face.");
  Vxpm_color_symbols = Qnil; /* initialized in x-faces.el */
#endif

  BUILD_GLYPH_INST (Vtruncation_glyph, truncator);
  BUILD_GLYPH_INST (Vcontinuation_glyph, continuer);
  BUILD_GLYPH_INST (Vxemacs_logo, xemacs);
}

#undef BUILD_GLYPH_INST
