xfaces.c

/* xfaces.c -- "Face" primitives.

Copyright (C) 1993-1994, 1998-2013 Free Software Foundation, Inc.

This file is part of GNU Emacs.

GNU Emacs 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 3 of the License, or
(at your option) any later version.

GNU Emacs 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 GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.  */

/* New face implementation by Gerd Moellmann <gerd@gnu.org>.  */

/* Faces.

   When using Emacs with X, the display style of characters can be
   changed by defining `faces'.  Each face can specify the following
   display attributes:

   1. Font family name.

   2. Font foundry name.

   3. Relative proportionate width, aka character set width or set
   width (swidth), e.g. `semi-compressed'.

   4. Font height in 1/10pt.

   5. Font weight, e.g. `bold'.

   6. Font slant, e.g. `italic'.

   7. Foreground color.

   8. Background color.

   9. Whether or not characters should be underlined, and in what color.

   10. Whether or not characters should be displayed in inverse video.

   11. A background stipple, a bitmap.

   12. Whether or not characters should be overlined, and in what color.

   13. Whether or not characters should be strike-through, and in what
   color.

   14. Whether or not a box should be drawn around characters, the box
   type, and, for simple boxes, in what color.

   15. Font-spec, or nil.  This is a special attribute.

   A font-spec is a collection of font attributes (specs).

   When this attribute is specified, the face uses a font matching
   with the specs as is except for what overwritten by the specs in
   the fontset (see below).  In addition, the other font-related
   attributes (1st thru 5th) are updated from the spec.

   On the other hand, if one of the other font-related attributes are
   specified, the corresponding specs in this attribute is set to nil.

   15. A face name or list of face names from which to inherit attributes.

   16. A specified average font width, which is invisible from Lisp,
   and is used to ensure that a font specified on the command line,
   for example, can be matched exactly.

   17. A fontset name.  This is another special attribute.

   A fontset is a mappings from characters to font-specs, and the
   specs overwrite the font-spec in the 14th attribute.


   Faces are frame-local by nature because Emacs allows to define the
   same named face (face names are symbols) differently for different
   frames.  Each frame has an alist of face definitions for all named
   faces.  The value of a named face in such an alist is a Lisp vector
   with the symbol `face' in slot 0, and a slot for each of the face
   attributes mentioned above.

   There is also a global face alist `Vface_new_frame_defaults'.  Face
   definitions from this list are used to initialize faces of newly
   created frames.

   A face doesn't have to specify all attributes.  Those not specified
   have a value of `unspecified'.  Faces specifying all attributes but
   the 14th are called `fully-specified'.


   Face merging.

   The display style of a given character in the text is determined by
   combining several faces.  This process is called `face merging'.
   Any aspect of the display style that isn't specified by overlays or
   text properties is taken from the `default' face.  Since it is made
   sure that the default face is always fully-specified, face merging
   always results in a fully-specified face.


   Face realization.

   After all face attributes for a character have been determined by
   merging faces of that character, that face is `realized'.  The
   realization process maps face attributes to what is physically
   available on the system where Emacs runs.  The result is a
   `realized face' in the form of a struct face which is stored in the
   face cache of the frame on which it was realized.

   Face realization is done in the context of the character to display
   because different fonts may be used for different characters.  In
   other words, for characters that have different font
   specifications, different realized faces are needed to display
   them.

   Font specification is done by fontsets.  See the comment in
   fontset.c for the details.  In the current implementation, all ASCII
   characters share the same font in a fontset.

   Faces are at first realized for ASCII characters, and, at that
   time, assigned a specific realized fontset.  Hereafter, we call
   such a face as `ASCII face'.  When a face for a multibyte character
   is realized, it inherits (thus shares) a fontset of an ASCII face
   that has the same attributes other than font-related ones.

   Thus, all realized faces have a realized fontset.


   Unibyte text.

   Unibyte text (i.e. raw 8-bit characters) is displayed with the same
   font as ASCII characters.  That is because it is expected that
   unibyte text users specify a font that is suitable both for ASCII
   and raw 8-bit characters.


   Font selection.

   Font selection tries to find the best available matching font for a
   given (character, face) combination.

   If the face specifies a fontset name, that fontset determines a
   pattern for fonts of the given character.  If the face specifies a
   font name or the other font-related attributes, a fontset is
   realized from the default fontset.  In that case, that
   specification determines a pattern for ASCII characters and the
   default fontset determines a pattern for multibyte characters.

   Available fonts on the system on which Emacs runs are then matched
   against the font pattern.  The result of font selection is the best
   match for the given face attributes in this font list.

   Font selection can be influenced by the user.

   1. The user can specify the relative importance he gives the face
   attributes width, height, weight, and slant by setting
   face-font-selection-order (faces.el) to a list of face attribute
   names.  The default is '(:width :height :weight :slant), and means
   that font selection first tries to find a good match for the font
   width specified by a face, then---within fonts with that
   width---tries to find a best match for the specified font height,
   etc.

   2. Setting face-font-family-alternatives allows the user to
   specify alternative font families to try if a family specified by a
   face doesn't exist.

   3. Setting face-font-registry-alternatives allows the user to
   specify all alternative font registries to try for a face
   specifying a registry.

   4. Setting face-ignored-fonts allows the user to ignore specific
   fonts.


   Character composition.

   Usually, the realization process is already finished when Emacs
   actually reflects the desired glyph matrix on the screen.  However,
   on displaying a composition (sequence of characters to be composed
   on the screen), a suitable font for the components of the
   composition is selected and realized while drawing them on the
   screen, i.e.  the realization process is delayed but in principle
   the same.


   Initialization of basic faces.

   The faces `default', `modeline' are considered `basic faces'.
   When redisplay happens the first time for a newly created frame,
   basic faces are realized for CHARSET_ASCII.  Frame parameters are
   used to fill in unspecified attributes of the default face.  */

#include <config.h>
#include "sysstdio.h"
#include <sys/types.h>
#include <sys/stat.h>

#include "lisp.h"
#include "character.h"
#include "charset.h"
#include "keyboard.h"
#include "frame.h"
#include "termhooks.h"

#ifdef USE_MOTIF
#include <Xm/Xm.h>
#include <Xm/XmStrDefs.h>
#endif /* USE_MOTIF */

#ifdef MSDOS
#include "dosfns.h"
#endif

#ifdef HAVE_WINDOW_SYSTEM
#include TERM_HEADER
#include "fontset.h"
#ifdef HAVE_NTGUI
#define x_display_info w32_display_info
#define GCGraphicsExposures 0
#endif /* HAVE_NTGUI */

#ifdef HAVE_NS
#define GCGraphicsExposures 0
#endif /* HAVE_NS */

/* Number of pt per inch (from the TeXbook).  */

#define PT_PER_INCH 72.27

#endif /* HAVE_WINDOW_SYSTEM */

#include "buffer.h"
#include "dispextern.h"
#include "blockinput.h"
#include "window.h"
#include "intervals.h"
#include "termchar.h"

#include "font.h"

#ifdef HAVE_X_WINDOWS

/* Compensate for a bug in Xos.h on some systems, on which it requires
   time.h.  On some such systems, Xos.h tries to redefine struct
   timeval and struct timezone if USG is #defined while it is
   #included.  */

#ifdef XOS_NEEDS_TIME_H
#include <time.h>
#undef USG
#include <X11/Xos.h>
#define USG
#define __TIMEVAL__
#if defined USG || defined __TIMEVAL__ /* Don't warn about unused macros.  */
#endif
#else /* not XOS_NEEDS_TIME_H */
#include <X11/Xos.h>
#endif /* not XOS_NEEDS_TIME_H */

#endif /* HAVE_X_WINDOWS */

#include <c-ctype.h>

/* Non-zero if face attribute ATTR is unspecified.  */

#define UNSPECIFIEDP(ATTR) EQ ((ATTR), Qunspecified)

/* Non-zero if face attribute ATTR is `ignore-defface'.  */

#define IGNORE_DEFFACE_P(ATTR) EQ ((ATTR), QCignore_defface)

/* Value is the number of elements of VECTOR.  */

#define DIM(VECTOR) (sizeof (VECTOR) / sizeof *(VECTOR))

/* Size of hash table of realized faces in face caches (should be a
   prime number).  */

#define FACE_CACHE_BUCKETS_SIZE 1001

/* Keyword symbols used for face attribute names.  */

Lisp_Object QCfamily, QCheight, QCweight, QCslant;
static Lisp_Object QCunderline;
static Lisp_Object QCinverse_video, QCstipple;
Lisp_Object QCforeground, QCbackground;
Lisp_Object QCwidth;
static Lisp_Object QCfont, QCbold, QCitalic;
static Lisp_Object QCreverse_video;
static Lisp_Object QCoverline, QCstrike_through, QCbox, QCinherit;
static Lisp_Object QCfontset;

/* Symbols used for attribute values.  */

Lisp_Object Qnormal;
Lisp_Object Qbold;
static Lisp_Object Qline, Qwave;
Lisp_Object Qextra_light, Qlight;
Lisp_Object Qsemi_light, Qsemi_bold, Qextra_bold, Qultra_bold;
Lisp_Object Qoblique;
Lisp_Object Qitalic;
static Lisp_Object Qreleased_button, Qpressed_button;
static Lisp_Object QCstyle, QCcolor, QCline_width;
Lisp_Object Qunspecified;	/* used in dosfns.c */
static Lisp_Object QCignore_defface;

char unspecified_fg[] = "unspecified-fg", unspecified_bg[] = "unspecified-bg";

/* The name of the function to call when the background of the frame
   has changed, frame_set_background_mode.  */

static Lisp_Object Qframe_set_background_mode;

/* Names of basic faces.  */

Lisp_Object Qdefault, Qtool_bar, Qfringe;
static Lisp_Object Qregion;
Lisp_Object Qheader_line, Qscroll_bar, Qcursor;
static Lisp_Object Qborder, Qmouse, Qmenu;
Lisp_Object Qmode_line_inactive;
static Lisp_Object Qvertical_border;

/* The symbol `face-alias'.  A symbols having that property is an
   alias for another face.  Value of the property is the name of
   the aliased face.  */

static Lisp_Object Qface_alias;

/* Alist of alternative font families.  Each element is of the form
   (FAMILY FAMILY1 FAMILY2 ...).  If fonts of FAMILY can't be loaded,
   try FAMILY1, then FAMILY2, ...  */

Lisp_Object Vface_alternative_font_family_alist;

/* Alist of alternative font registries.  Each element is of the form
   (REGISTRY REGISTRY1 REGISTRY2...).  If fonts of REGISTRY can't be
   loaded, try REGISTRY1, then REGISTRY2, ...  */

Lisp_Object Vface_alternative_font_registry_alist;

/* Allowed scalable fonts.  A value of nil means don't allow any
   scalable fonts.  A value of t means allow the use of any scalable
   font.  Otherwise, value must be a list of regular expressions.  A
   font may be scaled if its name matches a regular expression in the
   list.  */

static Lisp_Object Qscalable_fonts_allowed;

/* The symbols `foreground-color' and `background-color' which can be
   used as part of a `face' property.  This is for compatibility with
   Emacs 20.2.  */

Lisp_Object Qforeground_color, Qbackground_color;

/* The symbols `face' and `mouse-face' used as text properties.  */

Lisp_Object Qface;

/* Property for basic faces which other faces cannot inherit.  */

static Lisp_Object Qface_no_inherit;

/* Error symbol for wrong_type_argument in load_pixmap.  */

static Lisp_Object Qbitmap_spec_p;

/* The next ID to assign to Lisp faces.  */

static int next_lface_id;

/* A vector mapping Lisp face Id's to face names.  */

static Lisp_Object *lface_id_to_name;
static ptrdiff_t lface_id_to_name_size;

/* TTY color-related functions (defined in tty-colors.el).  */

static Lisp_Object Qtty_color_desc, Qtty_color_by_index, Qtty_color_standard_values;

/* The name of the function used to compute colors on TTYs.  */

static Lisp_Object Qtty_color_alist;

#ifdef HAVE_WINDOW_SYSTEM

/* Counter for calls to clear_face_cache.  If this counter reaches
   CLEAR_FONT_TABLE_COUNT, and a frame has more than
   CLEAR_FONT_TABLE_NFONTS load, unused fonts are freed.  */

static int clear_font_table_count;
#define CLEAR_FONT_TABLE_COUNT	100
#define CLEAR_FONT_TABLE_NFONTS	10

#endif /* HAVE_WINDOW_SYSTEM */

/* Non-zero means face attributes have been changed since the last
   redisplay.  Used in redisplay_internal.  */

int face_change_count;

/* Non-zero means don't display bold text if a face's foreground
   and background colors are the inverse of the default colors of the
   display.   This is a kluge to suppress `bold black' foreground text
   which is hard to read on an LCD monitor.  */

static int tty_suppress_bold_inverse_default_colors_p;

/* A list of the form `((x . y))' used to avoid consing in
   Finternal_set_lisp_face_attribute.  */

static Lisp_Object Vparam_value_alist;

/* The total number of colors currently allocated.  */

#ifdef GLYPH_DEBUG
static int ncolors_allocated;
static int npixmaps_allocated;
static int ngcs;
#endif

/* Non-zero means the definition of the `menu' face for new frames has
   been changed.  */

static int menu_face_changed_default;

struct named_merge_point;

static struct face *realize_face (struct face_cache *, Lisp_Object *,
				  int);
static struct face *realize_x_face (struct face_cache *, Lisp_Object *);
static struct face *realize_tty_face (struct face_cache *, Lisp_Object *);
static bool realize_basic_faces (struct frame *);
static bool realize_default_face (struct frame *);
static void realize_named_face (struct frame *, Lisp_Object, int);
static struct face_cache *make_face_cache (struct frame *);
static void free_face_cache (struct face_cache *);
static int merge_face_ref (struct frame *, Lisp_Object, Lisp_Object *,
			   int, struct named_merge_point *);

#ifdef HAVE_WINDOW_SYSTEM
static void set_font_frame_param (Lisp_Object, Lisp_Object);
static void clear_face_gcs (struct face_cache *);
static struct face *realize_non_ascii_face (struct frame *, Lisp_Object,
					    struct face *);
#endif /* HAVE_WINDOW_SYSTEM */

/***********************************************************************
			      Utilities
 ***********************************************************************/

#ifdef HAVE_X_WINDOWS

#ifdef DEBUG_X_COLORS

/* The following is a poor mans infrastructure for debugging X color
   allocation problems on displays with PseudoColor-8.  Some X servers
   like 3.3.5 XF86_SVGA with Matrox cards apparently don't implement
   color reference counts completely so that they don't signal an
   error when a color is freed whose reference count is already 0.
   Other X servers do.  To help me debug this, the following code
   implements a simple reference counting schema of its own, for a
   single display/screen.  --gerd.  */

/* Reference counts for pixel colors.  */

int color_count[256];

/* Register color PIXEL as allocated.  */

void
register_color (unsigned long pixel)
{
  eassert (pixel < 256);
  ++color_count[pixel];
}


/* Register color PIXEL as deallocated.  */

void
unregister_color (unsigned long pixel)
{
  eassert (pixel < 256);
  if (color_count[pixel] > 0)
    --color_count[pixel];
  else
    emacs_abort ();
}


/* Register N colors from PIXELS as deallocated.  */

void
unregister_colors (unsigned long *pixels, int n)
{
  int i;
  for (i = 0; i < n; ++i)
    unregister_color (pixels[i]);
}


DEFUN ("dump-colors", Fdump_colors, Sdump_colors, 0, 0, 0,
       doc: /* Dump currently allocated colors to stderr.  */)
  (void)
{
  int i, n;

  fputc ('\n', stderr);

  for (i = n = 0; i < sizeof color_count / sizeof color_count[0]; ++i)
    if (color_count[i])
      {
	fprintf (stderr, "%3d: %5d", i, color_count[i]);
	++n;
	if (n % 5 == 0)
	  fputc ('\n', stderr);
	else
	  fputc ('\t', stderr);
      }

  if (n % 5 != 0)
    fputc ('\n', stderr);
  return Qnil;
}

#endif /* DEBUG_X_COLORS */


/* Free colors used on frame F.  PIXELS is an array of NPIXELS pixel
   color values.  Interrupt input must be blocked when this function
   is called.  */

void
x_free_colors (struct frame *f, long unsigned int *pixels, int npixels)
{
  int class = FRAME_DISPLAY_INFO (f)->visual->class;

  /* If display has an immutable color map, freeing colors is not
     necessary and some servers don't allow it.  So don't do it.  */
  if (class != StaticColor && class != StaticGray && class != TrueColor)
    {
#ifdef DEBUG_X_COLORS
      unregister_colors (pixels, npixels);
#endif
      XFreeColors (FRAME_X_DISPLAY (f), FRAME_X_COLORMAP (f),
		   pixels, npixels, 0);
    }
}


#ifdef USE_X_TOOLKIT

/* Free colors used on frame F.  PIXELS is an array of NPIXELS pixel
   color values.  Interrupt input must be blocked when this function
   is called.  */

void
x_free_dpy_colors (Display *dpy, Screen *screen, Colormap cmap,
		   long unsigned int *pixels, int npixels)
{
  struct x_display_info *dpyinfo = x_display_info_for_display (dpy);
  int class = dpyinfo->visual->class;

  /* If display has an immutable color map, freeing colors is not
     necessary and some servers don't allow it.  So don't do it.  */
  if (class != StaticColor && class != StaticGray && class != TrueColor)
    {
#ifdef DEBUG_X_COLORS
      unregister_colors (pixels, npixels);
#endif
      XFreeColors (dpy, cmap, pixels, npixels, 0);
    }
}
#endif /* USE_X_TOOLKIT */

/* Create and return a GC for use on frame F.  GC values and mask
   are given by XGCV and MASK.  */

static GC
x_create_gc (struct frame *f, long unsigned int mask, XGCValues *xgcv)
{
  GC gc;
  block_input ();
  gc = XCreateGC (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), mask, xgcv);
  unblock_input ();
  IF_DEBUG (++ngcs);
  return gc;
}


/* Free GC which was used on frame F.  */

static void
x_free_gc (struct frame *f, GC gc)
{
  eassert (input_blocked_p ());
  IF_DEBUG ((--ngcs, eassert (ngcs >= 0)));
  XFreeGC (FRAME_X_DISPLAY (f), gc);
}

#endif /* HAVE_X_WINDOWS */

#ifdef HAVE_NTGUI
/* W32 emulation of GCs */

static GC
x_create_gc (struct frame *f, unsigned long mask, XGCValues *xgcv)
{
  GC gc;
  block_input ();
  gc = XCreateGC (NULL, FRAME_W32_WINDOW (f), mask, xgcv);
  unblock_input ();
  IF_DEBUG (++ngcs);
  return gc;
}


/* Free GC which was used on frame F.  */

static void
x_free_gc (struct frame *f, GC gc)
{
  IF_DEBUG ((--ngcs, eassert (ngcs >= 0)));
  xfree (gc);
}

#endif  /* HAVE_NTGUI */

#ifdef HAVE_NS
/* NS emulation of GCs */

static GC
x_create_gc (struct frame *f,
	     unsigned long mask,
	     XGCValues *xgcv)
{
  GC gc = xmalloc (sizeof *gc);
  *gc = *xgcv;
  return gc;
}

static void
x_free_gc (struct frame *f, GC gc)
{
  xfree (gc);
}
#endif  /* HAVE_NS */

/***********************************************************************
			   Frames and faces
 ***********************************************************************/

/* Initialize face cache and basic faces for frame F.  */

void
init_frame_faces (struct frame *f)
{
  /* Make a face cache, if F doesn't have one.  */
  if (FRAME_FACE_CACHE (f) == NULL)
    FRAME_FACE_CACHE (f) = make_face_cache (f);

#ifdef HAVE_WINDOW_SYSTEM
  /* Make the image cache.  */
  if (FRAME_WINDOW_P (f))
    {
      /* We initialize the image cache when creating the first frame
	 on a terminal, and not during terminal creation.  This way,
	 `x-open-connection' on a tty won't create an image cache.  */
      if (FRAME_IMAGE_CACHE (f) == NULL)
	FRAME_IMAGE_CACHE (f) = make_image_cache ();
      ++FRAME_IMAGE_CACHE (f)->refcount;
    }
#endif /* HAVE_WINDOW_SYSTEM */

  /* Realize basic faces.  Must have enough information in frame
     parameters to realize basic faces at this point.  */
#ifdef HAVE_X_WINDOWS
  if (!FRAME_X_P (f) || FRAME_X_WINDOW (f))
#endif
#ifdef HAVE_NTGUI
  if (!FRAME_WINDOW_P (f) || FRAME_W32_WINDOW (f))
#endif
#ifdef HAVE_NS
  if (!FRAME_NS_P (f) || FRAME_NS_WINDOW (f))
#endif
    if (!realize_basic_faces (f))
	emacs_abort ();
}


/* Free face cache of frame F.  Called from delete_frame.  */

void
free_frame_faces (struct frame *f)
{
  struct face_cache *face_cache = FRAME_FACE_CACHE (f);

  if (face_cache)
    {
      free_face_cache (face_cache);
      FRAME_FACE_CACHE (f) = NULL;
    }

#ifdef HAVE_WINDOW_SYSTEM
  if (FRAME_WINDOW_P (f))
    {
      struct image_cache *image_cache = FRAME_IMAGE_CACHE (f);
      if (image_cache)
	{
	  --image_cache->refcount;
	  if (image_cache->refcount == 0)
	    free_image_cache (f);
	}
    }
#endif /* HAVE_WINDOW_SYSTEM */
}


/* Clear face caches, and recompute basic faces for frame F.  Call
   this after changing frame parameters on which those faces depend,
   or when realized faces have been freed due to changing attributes
   of named faces. */

void
recompute_basic_faces (struct frame *f)
{
  if (FRAME_FACE_CACHE (f))
    {
      clear_face_cache (0);
      if (!realize_basic_faces (f))
	emacs_abort ();
    }
}


/* Clear the face caches of all frames.  CLEAR_FONTS_P non-zero means
   try to free unused fonts, too.  */

void
clear_face_cache (int clear_fonts_p)
{
#ifdef HAVE_WINDOW_SYSTEM
  Lisp_Object tail, frame;

  if (clear_fonts_p
      || ++clear_font_table_count == CLEAR_FONT_TABLE_COUNT)
    {
      /* From time to time see if we can unload some fonts.  This also
	 frees all realized faces on all frames.  Fonts needed by
	 faces will be loaded again when faces are realized again.  */
      clear_font_table_count = 0;

      FOR_EACH_FRAME (tail, frame)
	{
	  struct frame *f = XFRAME (frame);
	  if (FRAME_WINDOW_P (f)
	      && FRAME_DISPLAY_INFO (f)->n_fonts > CLEAR_FONT_TABLE_NFONTS)
	    {
	      clear_font_cache (f);
	      free_all_realized_faces (frame);
	    }
	}
    }
  else
    {
      /* Clear GCs of realized faces.  */
      FOR_EACH_FRAME (tail, frame)
	{
	  struct frame *f = XFRAME (frame);
	  if (FRAME_WINDOW_P (f))
	      clear_face_gcs (FRAME_FACE_CACHE (f));
	}
      clear_image_caches (Qnil);
    }
#endif /* HAVE_WINDOW_SYSTEM */
}


DEFUN ("clear-face-cache", Fclear_face_cache, Sclear_face_cache, 0, 1, 0,
       doc: /* Clear face caches on all frames.
Optional THOROUGHLY non-nil means try to free unused fonts, too.  */)
  (Lisp_Object thoroughly)
{
  clear_face_cache (!NILP (thoroughly));
  ++face_change_count;
  ++windows_or_buffers_changed;
  return Qnil;
}


/***********************************************************************
			      X Pixmaps
 ***********************************************************************/

#ifdef HAVE_WINDOW_SYSTEM

DEFUN ("bitmap-spec-p", Fbitmap_spec_p, Sbitmap_spec_p, 1, 1, 0,
       doc: /* Value is non-nil if OBJECT is a valid bitmap specification.
A bitmap specification is either a string, a file name, or a list
\(WIDTH HEIGHT DATA) where WIDTH is the pixel width of the bitmap,
HEIGHT is its height, and DATA is a string containing the bits of
the pixmap.  Bits are stored row by row, each row occupies
\(WIDTH + 7)/8 bytes.  */)
  (Lisp_Object object)
{
  bool pixmap_p = 0;

  if (STRINGP (object))
    /* If OBJECT is a string, it's a file name.  */
    pixmap_p = 1;
  else if (CONSP (object))
    {
      /* Otherwise OBJECT must be (WIDTH HEIGHT DATA), WIDTH and
	 HEIGHT must be ints > 0, and DATA must be string large
	 enough to hold a bitmap of the specified size.  */
      Lisp_Object width, height, data;

      height = width = data = Qnil;

      if (CONSP (object))
	{
	  width = XCAR (object);
	  object = XCDR (object);
	  if (CONSP (object))
	    {
	      height = XCAR (object);
	      object = XCDR (object);
	      if (CONSP (object))
		data = XCAR (object);
	    }
	}

      if (STRINGP (data)
	  && RANGED_INTEGERP (1, width, INT_MAX)
	  && RANGED_INTEGERP (1, height, INT_MAX))
	{
	  int bytes_per_row = ((XINT (width) + BITS_PER_CHAR - 1)
			       / BITS_PER_CHAR);
	  if (XINT (height) <= SBYTES (data) / bytes_per_row)
	    pixmap_p = 1;
	}
    }

  return pixmap_p ? Qt : Qnil;
}


/* Load a bitmap according to NAME (which is either a file name or a
   pixmap spec) for use on frame F.  Value is the bitmap_id (see
   xfns.c).  If NAME is nil, return with a bitmap id of zero.  If
   bitmap cannot be loaded, display a message saying so, and return
   zero.  Store the bitmap width in *W_PTR and its height in *H_PTR,
   if these pointers are not null.  */

static ptrdiff_t
load_pixmap (struct frame *f, Lisp_Object name, unsigned int *w_ptr,
	     unsigned int *h_ptr)
{
  ptrdiff_t bitmap_id;

  if (NILP (name))
    return 0;

  CHECK_TYPE (!NILP (Fbitmap_spec_p (name)), Qbitmap_spec_p, name);

  block_input ();
  if (CONSP (name))
    {
      /* Decode a bitmap spec into a bitmap.  */

      int h, w;
      Lisp_Object bits;

      w = XINT (Fcar (name));
      h = XINT (Fcar (Fcdr (name)));
      bits = Fcar (Fcdr (Fcdr (name)));

      bitmap_id = x_create_bitmap_from_data (f, SSDATA (bits),
					     w, h);
    }
  else
    {
      /* It must be a string -- a file name.  */
      bitmap_id = x_create_bitmap_from_file (f, name);
    }
  unblock_input ();

  if (bitmap_id < 0)
    {
      add_to_log ("Invalid or undefined bitmap `%s'", name, Qnil);
      bitmap_id = 0;

      if (w_ptr)
	*w_ptr = 0;
      if (h_ptr)
	*h_ptr = 0;
    }
  else
    {