/* "Face" primitives.
   Copyright (C) 1993 Free Software Foundation.

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 2, 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; see the file COPYING.  If not, write to
the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */

/* This is derived from work by Lucid (some parts very loosely so).  */

#include <sys/types.h>
#include <sys/stat.h>

#include "config.h"
#include "lisp.h"

#ifdef PC_FACES

#include "buffer.h"
#include "dispextern.h"
#include "frame.h"
#include "window.h"
#include "pc-term.h"


/* An explanation of the face data structures.  */

/* ========================= Face Data Structures =========================

   All lisp code uses symbols as face names.

   Each frame has a face_alist member (with the frame-face-alist and
   set-frame-face-alist accessors), associating the face names with
   vectors of the form 
       [face NAME ID FONT FOREGROUND BACKGROUND BACKGROUND-PIXMAP UNDERLINE-P]
   where
       face is the symbol `face',
       NAME is the symbol with which this vector is associated (a backpointer),
       ID is the face ID, an integer used internally by the C code to identify
           the face,
       FONT, FOREGROUND, and BACKGROUND are strings naming the fonts and colors
           to use with the face,
       BACKGROUND-PIXMAP is the name of an x bitmap filename, which we don't
           use right now, and
       UNDERLINE-P is non-nil if the face should be underlined.
   If any of these elements are nil, that allows the frame's parameters to
   show through.
   (lisp/faces.el maintains these association lists.)

   The frames' private alists hold the frame-local definitions for the
   faces.  The lisp variable global-face-data contains the global
   defaults for faces.  (See lisp/faces.el for this too.)

   In the C code, we also have a `struct face' with the elements
      `foreground', `background', `font', and `underline',
   which specify its visual appearance, and elements
      `gc' and `cached_index';
   `gc' may be an X GC which has been built for the given display
   parameters.  Faces with GC's are called `display faces'.  Whether
   or not a face has a GC depends on what data structure the face is
   in; we explain these more below.  (See src/dispextern.h.)

   Each frame also has members called `faces' and `n_faces' (with the
   accessors FRAME_FACES and FRAME_N_FACES), which define an array of
   struct face pointers, indexed by face ID (element 2 of the
   vector).  These are called "frame faces".
      Element 0 is the default face --- the one used for normal text.
      Element 1 is the modeline face.
   These faces have their GC's set; the rest do not.
   If faces[i] is filled in (i.e. non-zero) on one frame, then it must
   be filled in on all frames.  Code assumes that face ID's can be
   used on any frame.  (See src/xterm.h.)

   The global variables `face_vector' and `nfaces' define another
   array of struct face pointers, with their GC's set.  This array
   acts as a cache of GC's to be used by all frames.  The function
   `intern_face', passed a struct face *, searches face_vector for a
   struct face with the same parameters, adds a new one with a GC if
   it doesn't find one, and returns it.  If you have a `struct face',
   and you want a GC for it, call intern_face on that struct, and it
   will return a `struct face *' with its GC set.  The faces in
   face_vector are called `cached faces.' (See src/xfaces.c.)

   The `GLYPH' data type is an unsigned integer type; the bottom byte
   is a character code, and the byte above that is a face id.  The
   `struct frame_glyphs' structure, used to describe frames' current
   or desired contents, is essentially a matrix of GLYPHs; the face
   ID's in a struct frame_glyphs are indices into FRAME_FACES.  (See
   src/dispextern.h.)

   Some subtleties:
   
   Since face_vector is just a cache --- there are no pointers into it
   from the rest of the code, and everyone accesses it through
   intern_face --- we could just free its GC's and throw the whole
   thing away without breaking anything.  This gives us a simple way
   to garbage-collect old GC's nobody's using any more - we can just
   purge face_vector, and then let subsequent calls to intern_face
   refill it as needed.  The function clear_face_vector performs this
   purge.

   We're often applying intern_face to faces in frames' local arrays -
   for example, we do this while sending GLYPHs from a struct
   frame_glyphs to X during redisplay.  It would be nice to avoid
   searching all of face_vector every time we intern a frame's face.
   So, when intern_face finds a match for FACE in face_vector, it
   stores the index of the match in FACE's cached_index member, and
   checks there first next time.  */
   

/* Definitions and declarations.  */

static Lisp_Object Vemacs_pc_translate_x11_colors;

/* A table of display faces.  */
static struct face **face_vector;
/* The length in use of the table.  */
static int nfaces;
/* The allocated length of the table.   */
static int nfaces_allocated;

/* The number of face-id's in use (same for all frames).  */
static int next_face_id;

/* The number of the face to use to indicate the region.  */
static int region_face;

/* This is what appears in a slot in a face to signify that the face
   does not specify that display aspect.  */
#define FACE_DEFAULT (~0)

Lisp_Object Qface, Qwindow, Qpriority;

static void build_face ( /* FRAME_PTR, struct face * */ );
int face_name_id_number ( /* FRAME_PTR, Lisp_Object name */ );

static char *get_color_name(/* int attr */);

struct face *intern_face ( /* FRAME_PTR, struct face * */ );
static void ensure_face_ready ( /* FRAME_PTR, int id */ );
void recompute_basic_faces ( /* FRAME_PTR f */ );

/* Allocating, copying, and comparing struct faces.  */

/* Allocate a new face */
static struct face *
allocate_face ()
{
  struct face *result = (struct face *) xmalloc (sizeof (struct face));
  bzero (result, sizeof (struct face));
  result->foreground = FACE_DEFAULT;
  result->background = FACE_DEFAULT;
  return result;
}

/* Make a new face that's a copy of an existing one.  */
static struct face *
copy_face (face)
     struct face *face;
{
  struct face *result = allocate_face ();

  result->foreground = face->foreground;
  result->foreground_color_name = face->foreground_color_name;
  result->background = face->background;
  result->background_color_name = face->background_color_name;

  return result;
}

static int
face_eql (face1, face2)
     struct face *face1, *face2;
{
  return (   face1->foreground == face2->foreground
	  && face1->background == face2->background);
}

/* Interning faces in the `face_vector' cache, and clearing that cache.  */

/* Return the unique display face corresponding to the user-level face FACE.
   If there isn't one, make one, and find a slot in the face_vector to
   put it in.  */
static struct face *
get_cached_face (f, face)
     FRAME_PTR f;
     struct face *face;
{
  int i, empty = -1;
  struct face *result;

  /* Perhaps FACE->cached_index is valid; this could happen if FACE is
     in a frame's face list.  */
  if (face->cached_index >= 0
      && face->cached_index < nfaces
      && face_eql (face_vector[face->cached_index], face))
    return face_vector[face->cached_index];

  /* Look for an existing display face that does the job.
     Also find an empty slot if any.   */
  for (i = 0; i < nfaces; i++)
    {
      if (face_eql (face_vector[i], face))
	return face_vector[i];
      if (face_vector[i] == 0)
	empty = i;
    }

  /* If no empty slots, make one.  */
  if (empty < 0 && nfaces == nfaces_allocated)
    {
      int newsize = nfaces + 20;
      face_vector
	= (struct face **) xrealloc (face_vector,
				     newsize * sizeof (struct face *));
      nfaces_allocated = newsize;
    }

  if (empty < 0)
    empty = nfaces++;

  /* Put a new display face in the empty slot.  */
  result = copy_face (face);
  face_vector[empty] = result;
  
  build_face (f, result);

  return result;
}

/* Given a frame face, return an equivalent display face
   (one which has a graphics context).  */

struct face *
intern_face (f, face)
     FRAME_PTR f;
     struct face *face;
{
  /* If it's equivalent to the default face, use that.  */
  if (face_eql (face, FRAME_DEFAULT_FACE (f)))
    {
      build_face (f, FRAME_DEFAULT_FACE (f));
      return FRAME_DEFAULT_FACE (f);
    }
  
  /* If it's equivalent to the mode line face, use that.  */
  if (face_eql (face, FRAME_MODE_LINE_FACE (f)))
    {
      build_face (f, FRAME_MODE_LINE_FACE (f));
      return FRAME_MODE_LINE_FACE (f);
    }
  
  /* Get a specialized display face.  */
  return get_cached_face (f, face);
}

/* Clear out face_vector and start anew.
   This should be done from time to time just to avoid
   keeping too many graphics contexts in face_vector
   that are no longer needed.  */

void
clear_face_vector ()
{
  Lisp_Object rest;
  int i;

  /* Free the display faces in the face_vector.  */
  for (i = 0; i < nfaces; i++)
    {
      struct face *face = face_vector[i];
      xfree (face);
    }
  nfaces = 0;
}

#define GET_ATTRIBUTE(c, a)		(((c) != FACE_DEFAULT) ? (c) : (a))
#define GET_ATTRIBUTE_FROM_COLORS(b, f)	((((b) & 0x07) << 4) | ((f) & 0x8f))

static void reset_face_attribute(face)
     struct face *face;
{
  int		foreground, background;
  extern int	pc_normal_attrib, pc_highli_attrib;

  foreground = GET_ATTRIBUTE(face->foreground, pc_normal_attrib & 0x8f);
  background = GET_ATTRIBUTE(face->background, (pc_normal_attrib & 0x70) >> 4);

  face->attribute = GET_ATTRIBUTE_FROM_COLORS(background, foreground);
}


static void
build_face_colors(face)
     struct face *face;
{
  int		foreground, background;
  extern int	pc_normal_attrib, pc_highli_attrib;

  foreground = GET_ATTRIBUTE(face->foreground, pc_normal_attrib & 0x8f);
  background = GET_ATTRIBUTE(face->background, (pc_normal_attrib & 0x70) >> 4);

  face->foreground_color_name = get_color_name(foreground);
  face->background_color_name = get_color_name(background);

  face->attribute = GET_ATTRIBUTE_FROM_COLORS(background, foreground);
}


static void
build_face (f, face)
     FRAME_PTR f;
     struct face *face;
{
  build_face_colors(face);
}

/*****************************************************************************/
/*
 * One of these days, this needs to be cleaned up ...
 */
#include "pc-rgb.h"	/* ccb@soton.ac.uk */

/*****************************************************************************/

#define FOREGROUND_ATTRIBUTE	0x0001
#define BACKGROUND_ATTRIBUTE	0x0002

static struct pc_color_tab {
  char			*name;
  unsigned char		attribute;
  int			type_flags;
} color_table[] = {
  { "black",		0,	FOREGROUND_ATTRIBUTE | BACKGROUND_ATTRIBUTE},
  { "blue",		1,	FOREGROUND_ATTRIBUTE | BACKGROUND_ATTRIBUTE},
  { "green",		2,	FOREGROUND_ATTRIBUTE | BACKGROUND_ATTRIBUTE},
  { "cyan",		3,	FOREGROUND_ATTRIBUTE | BACKGROUND_ATTRIBUTE},
  { "red",		4,	FOREGROUND_ATTRIBUTE | BACKGROUND_ATTRIBUTE},
  { "magenta",		5,	FOREGROUND_ATTRIBUTE | BACKGROUND_ATTRIBUTE},
  { "brown",		6,	FOREGROUND_ATTRIBUTE | BACKGROUND_ATTRIBUTE},
  { "white",		7,	FOREGROUND_ATTRIBUTE | BACKGROUND_ATTRIBUTE},
  { "gray",		8,	FOREGROUND_ATTRIBUTE},
  { "lightblue",	9,	FOREGROUND_ATTRIBUTE},
  { "lightgreen",	10,	FOREGROUND_ATTRIBUTE},
  { "lightcyan",	11,	FOREGROUND_ATTRIBUTE},
  { "lightred",		12,	FOREGROUND_ATTRIBUTE},
  { "lightmagenta",	13,	FOREGROUND_ATTRIBUTE},
  { "yellow",		14,	FOREGROUND_ATTRIBUTE},
  { "brightwhite",	15,	FOREGROUND_ATTRIBUTE},
  /*
   * These "colors" are intended for use by `invert-face'.
   * When colors are inverted, we want something reasonable to happen when
   * a "bright" color is specified for the background.
   */
  { "gray",		0,	BACKGROUND_ATTRIBUTE},
  { "lightblue",	1,	BACKGROUND_ATTRIBUTE},
  { "lightgreen",	2,	BACKGROUND_ATTRIBUTE},
  { "lightcyan",	3,	BACKGROUND_ATTRIBUTE},
  { "lightred",		4,	BACKGROUND_ATTRIBUTE},
  { "lightmagenta",	5,	BACKGROUND_ATTRIBUTE},
  { "yellow",		6,	BACKGROUND_ATTRIBUTE},
  { "brightwhite",	7,	BACKGROUND_ATTRIBUTE},
  /*
   * These are for blinking foreground attributes
   */
  { "blinkingblack",	0+0x80,	FOREGROUND_ATTRIBUTE},
  { "blinkingblue",	1+0x80,	FOREGROUND_ATTRIBUTE},
  { "blinkinggreen",	2+0x80,	FOREGROUND_ATTRIBUTE},
  { "blinkingcyan",	3+0x80,	FOREGROUND_ATTRIBUTE},
  { "blinkingred",	4+0x80,	FOREGROUND_ATTRIBUTE},
  { "blinkingmagenta",	5+0x80,	FOREGROUND_ATTRIBUTE},
  { "blinkingbrown",	6+0x80,	FOREGROUND_ATTRIBUTE},
  { "blinkingwhite",	7+0x80,	FOREGROUND_ATTRIBUTE},
  { "blinkinggray",	8+0x80,	FOREGROUND_ATTRIBUTE},
  { "blinkinglightblue",9+0x80,	FOREGROUND_ATTRIBUTE},
  { "blinkinglightgreen",10+0x80,	FOREGROUND_ATTRIBUTE},
  { "blinkinglightcyan",11+0x80,	FOREGROUND_ATTRIBUTE},
  { "blinkinglightred",	12+0x80,	FOREGROUND_ATTRIBUTE},
  { "blinkinglightmagenta",13+0x80,	FOREGROUND_ATTRIBUTE},
  { "blinkingyellow",	14+0x80,	FOREGROUND_ATTRIBUTE},
  { "blinkingbrightwhite",15+0x80,	FOREGROUND_ATTRIBUTE},
  { NULL,		0,	0 }		/* end of table marker */
};

static int
load_color (f, name, type)
     FRAME_PTR f;
     Lisp_Object name;
     int type;
{
  int			color, result, color_found;
  struct pc_color_tab	*current;
  char			*color_name;

  if (NILP (name))
    {
      if (type & FOREGROUND_ATTRIBUTE)
	return 7;		/* white */
      return 0;			/* black */
    }

  CHECK_STRING (name, 0);
  color_name = (char *) XSTRING (name)->data;
  color_found = 0;
  for (current = color_table; current->name != NULL; current++)
    {
      if (stricmp(color_name, current->name) == 0)
	{
	  color_found = 1;
	  if (current->type_flags & type)
	    break;
	}
    }
  if ((current->name == NULL) &&	/* ccb@soton.ac.uk */
      !EQ(Vemacs_pc_translate_x11_colors, Qnil))
    {
      unsigned char attrib;

      if (pc_find_rgb_color(color_name, &attrib))
	{
	  if (type & BACKGROUND_ATTRIBUTE)
	    {
	      attrib &= 0x07;
	    }
	  return attrib;
	}
    }
  if (current->name == NULL)
    Fsignal (Qerror, Fcons (build_string ("undefined color"),
			    Fcons (name, Qnil)));
  if ((current->type_flags & type) == 0)
    Fsignal (Qerror, Fcons (build_string ("illegal color type"),
			    Fcons (name, Qnil)));
  return (current->attribute);
}


static char *
get_color_name(attr)
int	attr;
{
  struct pc_color_tab	*current;

  for (current = color_table; current->name != NULL; ++current)
    {
      if (current->attribute == attr)
	break;
    }
  if (current->name)
    return (current->name);
  return (NULL);
}

/* Initializing face arrays for frames. */

void
init_frame_faces (f)
     FRAME_PTR f;
{
  ensure_face_ready (f, 0);
  ensure_face_ready (f, 1);

  recompute_basic_faces (f);
}


/* Called from Fdelete_frame.  */
void
free_frame_faces (f)
     FRAME_PTR f;
{
  int i;

  for (i = 0; i < FRAME_N_FACES (f); i++)
    {
      struct face *face = FRAME_FACES (f) [i];
      if (face)
	{
	  xfree (face);
	}
    }
  xfree (FRAME_FACES (f));
  FRAME_FACES (f) = 0;
  FRAME_N_FACES (f) = 0;
}

/* Interning faces in a frame's face array.  */

/* Find a match for NEW_FACE in a FRAME's face array, and add it if we don't
   find one.  */
static int
intern_frame_face (frame, new_face)
     FRAME_PTR frame;
     struct face *new_face;
{
  int len = FRAME_N_FACES (frame);
  int i;

  /* Search for a face already on FRAME equivalent to FACE.  */
  for (i = 0; i < len; i++)
    {
      struct face *frame_face = FRAME_FACES (frame)[i];
      
      if (frame_face && face_eql (new_face, frame_face))
	return i;
    }

  /* We didn't find one; add a new one.  */
  i = next_face_id++;

  ensure_face_ready (frame, i);
  bcopy (new_face, FRAME_FACES (frame)[i], sizeof (*new_face));
  FRAME_FACES (frame)[i]->copy = 1;

  return i;
}

/* Make face id ID valid on frame F.  */

static void
ensure_face_ready (f, id)
     FRAME_PTR f;
     int id;
{
  if (FRAME_N_FACES (f) <= id)
    {
      int n = id + 10;
      int i;
      if (!FRAME_N_FACES (f))
	FRAME_FACES (f)
	  = (struct face **) xmalloc (sizeof (struct face *) * n);
      else
	FRAME_FACES (f)
	  = (struct face **) xrealloc (FRAME_FACES (f),
				       sizeof (struct face *) * n);

      bzero (FRAME_FACES (f) + FRAME_N_FACES (f),
	     (n - FRAME_N_FACES (f)) * sizeof (struct face *));
      FRAME_N_FACES (f) = n;
    }

  if (FRAME_FACES (f) [id] == 0)
    FRAME_FACES (f) [id] = allocate_face ();
}

/* Modify face TO by copying from FROM all properties which have
   nondefault settings.  */
static void 
merge_faces (from, to)
     struct face *from, *to;
{
  if (from->foreground != FACE_DEFAULT)
    {
      to->foreground = from->foreground;
    }
  if (from->background != FACE_DEFAULT)
    {
      to->background = from->background;
    }
  build_face_colors(to);
}

/* Set up the basic set of facial parameters, based on the frame's
   data; all faces are deltas applied to this.  */
static void
compute_base_face (f, face)
     FRAME_PTR f;
     struct face *face;
{
  extern int pc_normal_attrib, pc_highli_attrib;

  face->foreground = pc_normal_attrib & 0x8f;
  face->background = (pc_normal_attrib & 0x70) >> 4;

  /* Avoid a face comparison by making this invalid.  */
  face->cached_index = -1;
}


struct sortvec
{
  Lisp_Object overlay;
  int beg, end;
  int priority;
};

static int
sort_overlays (s1, s2)
     struct sortvec *s1, *s2;
{
  if (s1->priority != s2->priority)
    return s1->priority - s2->priority;
  if (s1->beg != s2->beg)
    return s1->beg - s2->beg;
  if (s1->end != s2->end)
    return s2->end - s1->end;
  return 0;
}

/* Return the face ID associated with a buffer position POS.
   Store into *ENDPTR the position at which a different face is needed.
   This does not take account of glyphs that specify their own face codes.
   F is the frame in use for display, and W is a window displaying
   the current buffer.

   REGION_BEG, REGION_END delimit the region, so it can be highlighted.  */

int
compute_char_face (f, w, pos, region_beg, region_end, endptr)
     FRAME_PTR f;
     struct window *w;
     int pos;
     int region_beg, region_end;
     int *endptr;
{
  struct face face;
  Lisp_Object prop, position;
  int i, j, noverlays;
  int facecode;
  Lisp_Object *overlay_vec;
  struct sortvec *sortvec;
  int endpos;

  /* W must display the current buffer.  We could write this function
     to use the frame and buffer of W, but right now it doesn't.  */
  if (XBUFFER (w->buffer) != current_buffer)
    abort ();

  endpos = ZV;
  if (pos < region_beg && region_beg < endpos)
    endpos = region_beg;

  XFASTINT (position) = pos;
  prop = Fget_text_property (position, Qface, w->buffer);
  {
    Lisp_Object end;

    end = Fnext_single_property_change (position, Qface, w->buffer);
    if (INTEGERP (end))
      endpos = XINT (end);
  }

  {
    int next_overlay;
    int len;

    /* First try with room for 40 overlays.  */
    len = 40;
    overlay_vec = (Lisp_Object *) alloca (len * sizeof (Lisp_Object));
    
    noverlays = overlays_at (pos, 0, &overlay_vec, &len, &next_overlay);

    /* If there are more than 40,
       make enough space for all, and try again.  */
    if (noverlays > len)
      {
	len = noverlays;
	overlay_vec = (Lisp_Object *) alloca (len * sizeof (Lisp_Object));
	noverlays = overlays_at (pos, 0, &overlay_vec, &len, &next_overlay);
      }

    if (next_overlay < endpos)
      endpos = next_overlay;
  }

  *endptr = endpos;

  /* Optimize the default case.  */
  if (noverlays == 0 && NILP (prop)
      && !(pos >= region_beg && pos < region_end))
    return 0;

  compute_base_face (f, &face);

  if (!NILP (prop))
    {
      facecode = face_name_id_number (f, prop);
      if (facecode >= 0 && facecode < FRAME_N_FACES (f)
	  && FRAME_FACES (f) [facecode] != 0)
	merge_faces (FRAME_FACES (f) [facecode], &face);
    }

  /* Put the valid and relevant overlays into sortvec.  */
  sortvec = (struct sortvec *) alloca (noverlays * sizeof (struct sortvec));

  for (i = 0, j = 0; i < noverlays; i++)
    {
      Lisp_Object overlay = overlay_vec[i];

      if (OVERLAY_VALID (overlay)
	  && OVERLAY_POSITION (OVERLAY_START (overlay)) > 0
	  && OVERLAY_POSITION (OVERLAY_END (overlay)) > 0)
	{
	  Lisp_Object window;
	  window = Foverlay_get (overlay, Qwindow);

	  /* Also ignore overlays limited to one window
	     if it's not the window we are using.  */
	  if (XTYPE (window) != Lisp_Window
	      || XWINDOW (window) == w)
	    {
	      Lisp_Object tem;

	      /* This overlay is good and counts:
		 put it in sortvec.  */
	      sortvec[j].overlay = overlay;
	      sortvec[j].beg = OVERLAY_POSITION (OVERLAY_START (overlay));
	      sortvec[j].end = OVERLAY_POSITION (OVERLAY_END (overlay));
	      tem = Foverlay_get (overlay, Qpriority);
	      if (INTEGERP (tem))
		sortvec[j].priority = XINT (tem);
	      else
		sortvec[j].priority = 0;
	      j++;
	    }
	}
    }
  noverlays = j;

  /* Sort the overlays into the proper order: increasing priority.  */

  if (noverlays > 1)
    qsort (sortvec, noverlays, sizeof (struct sortvec), sort_overlays);

  /* Now merge the overlay data in that order.  */
  for (i = 0; i < noverlays; i++)
    {
      prop = Foverlay_get (sortvec[i].overlay, Qface);
      if (!NILP (prop))
	{
	  Lisp_Object oend;
	  int oendpos;

	  facecode = face_name_id_number (f, prop);
	  if (facecode >= 0 && facecode < FRAME_N_FACES (f)
	      && FRAME_FACES (f) [facecode] != 0)
	    merge_faces (FRAME_FACES (f) [facecode], &face);

	  oend = OVERLAY_END (sortvec[i].overlay);
	  oendpos = OVERLAY_POSITION (oend);
	  if (oendpos < endpos)
	    endpos = oendpos;
	}
    }

  if (pos >= region_beg && pos < region_end)
    {
      if (region_end < endpos)
	endpos = region_end;
      if (region_face >= 0 && region_face < next_face_id)
	merge_faces (FRAME_FACES (f) [region_face], &face);
    }

  *endptr = endpos;

  return intern_frame_face (f, &face);
}

/* Return the face ID to use to display a special glyph which selects
   FACE_CODE as the face ID, assuming that ordinarily the face would
   be BASIC_FACE.  F is the frame.  */
int
compute_glyph_face (f, face_code)
     FRAME_PTR f;
     int face_code;
{
  struct face face;

  compute_base_face (f, &face);

  if (face_code >= 0 && face_code < FRAME_N_FACES (f)
      && FRAME_FACES (f) [face_code] != 0)
    merge_faces (FRAME_FACES (f) [face_code], &face);

  return intern_frame_face (f, &face);
}


/* Recompute the GC's for the default and modeline faces.
   We call this after changing frame parameters on which those GC's
   depend.  */
void
recompute_basic_faces (f)
     FRAME_PTR f;
{
  /* If the frame's faces haven't been initialized yet, don't worry about
     this stuff.  */
  if (FRAME_N_FACES (f) < 2)
    return;

  build_face (f, FRAME_DEFAULT_FACE (f));

  build_face (f, FRAME_MODE_LINE_FACE (f));
}



/* Lisp interface. */

#ifdef MULTI_FRAME
The code past this point does not work with MULTI_FRAME!
#endif

DEFUN ("frame-face-alist", Fframe_face_alist, Sframe_face_alist, 1, 1, 0,
       "")
     (frame)
     Lisp_Object frame;
{
  return the_only_frame.face_alist;
}

DEFUN ("set-frame-face-alist", Fset_frame_face_alist, Sset_frame_face_alist,
       2, 2, 0, "")
     (frame, value)
     Lisp_Object frame, value;
{
  the_only_frame.face_alist = value;
  return value;
}


DEFUN ("make-face-internal", Fmake_face_internal, Smake_face_internal, 1, 1, 0,
  "Create face number FACE-ID on all frames.")
  (face_id)
     Lisp_Object face_id;
{
  Lisp_Object rest;
  int id = XINT (face_id);

  CHECK_NUMBER (face_id, 0);
  if (id < 0 || id >= next_face_id)
    error ("Face id out of range");

  ensure_face_ready (Qnil, id);
  return Qnil;
}


DEFUN ("set-face-attribute-internal", Fset_face_attribute_internal,
       Sset_face_attribute_internal, 4, 4, 0, "")
     (face_id, attr_name, attr_value, frame)
     Lisp_Object face_id, attr_name, attr_value, frame;
{
  struct face *face;
  FRAME_PTR f;
  int magic_p;
  int id;

  CHECK_NUMBER (face_id, 0);
  CHECK_SYMBOL (attr_name, 0);

  f = NULL;
  id = XINT (face_id);
  if (id < 0 || id >= next_face_id)
    error ("Face id out of range");

  ensure_face_ready (f, id);
  face = FRAME_FACES (f) [XFASTINT (face_id)];

  if (EQ (attr_name, intern ("font")))
    {
      /* do nothing */
    }
  else if (EQ (attr_name, intern ("foreground")))
    {
      int new_color = load_color (f, attr_value, FOREGROUND_ATTRIBUTE);
      face->foreground = new_color;
    }
  else if (EQ (attr_name, intern ("background")))
    {
      int new_color = load_color (f, attr_value, BACKGROUND_ATTRIBUTE);
      face->background = new_color;
    }
  else if (EQ (attr_name, intern ("underline")))
    {
#if 0	/* ignore this */
      int new = !NILP (attr_value);
      face->underline = new;
#endif
    }
  else
    error ("unknown face attribute");

  if (id == 0)
    {
      build_face (f, FRAME_DEFAULT_FACE (f));
    }

  if (id == 1)
    {
      build_face (f, FRAME_MODE_LINE_FACE (f));
    }

  /* If we're modifying either of the frame's display faces, that
     means that we're changing the parameters of a fixed face code;
     since the color/font/whatever is changed but the face ID hasn't,
     redisplay won't know to redraw the affected sections.  Give it a
     kick.  */
  if (id == 0 || id == 1)
    SET_FRAME_GARBAGED (f);
  else
    /* Otherwise, it's enough to tell it to redisplay the text.  */
    windows_or_buffers_changed = 1;

  return Qnil;
}

DEFUN ("internal-next-face-id", Finternal_next_face_id, Sinternal_next_face_id,
  0, 0, 0, "")
  ()
{
  return make_number (next_face_id++);
}

/* Return the face id for name NAME on frame FRAME.
   (It should be the same for all frames,
   but it's as easy to use the "right" frame to look it up
   as to use any other one.)  */

int
face_name_id_number (f, name)
     FRAME_PTR f;
     Lisp_Object name;
{
  Lisp_Object tem;

  tem = Fcdr (assq_no_quit (name, the_only_frame.face_alist));
  if (NILP (tem))
    return 0;
  CHECK_VECTOR (tem, 0);
  tem = XVECTOR (tem)->contents[2];
  CHECK_NUMBER (tem, 0);
  return XINT (tem);
}

Lisp_Object Qforeground_color;
Lisp_Object Qbackground_color;

DEFUN ("frame-parameters", Fframe_parameters, Sframe_parameters, 0, 1, 0,
  "Return the parameters-alist of frame FRAME.\n\
It is a list of elements of the form (PARM . VALUE), where PARM is a symbol.\n\
The meaningful PARMs depend on the kind of frame.\n\
If FRAME is omitted, return information on the currently selected frame.")
  (frame)
     Lisp_Object frame;
{
  Lisp_Object	alist;
  struct gcpro	gcpro1;
  struct face	*face;

  face = FRAME_DEFAULT_FACE (NULL);
  build_face(NULL, face);		/* get colors */
  alist = Qnil;
  GCPRO1(alist);
  if (face->background_color_name)
    {
      alist = Fcons(Fcons(Qbackground_color,
			  build_string(face->background_color_name)), alist);
    }
  if (face->foreground_color_name)
    {
      alist = Fcons(Fcons(Qforeground_color,
			  build_string(face->foreground_color_name)), alist);
    }
  /*
   * Stick a dummy font into the list.
   */
  alist = Fcons(Fcons(intern ("font"), build_string ("fixed")), alist);
  UNGCPRO;
  return (alist);
}
/*
 * Set the foreground color.
 */
DEFUN ("emacs-pc-set-default-foreground-color",
       Femacs_pc_set_default_foreground_color,
       Semacs_pc_set_default_foreground_color, 1, 1, 0,
       "Set the foreground color.  Experimental.  Do not use.")
	   (color)
	 Lisp_Object color;
{
  extern int pc_normal_attrib;
  int new_color;

  CHECK_STRING (color, 0);

  new_color = load_color (selected_frame, color, FOREGROUND_ATTRIBUTE);
  pc_normal_attrib = (pc_normal_attrib & 0x70) | (new_color & 0x8f);
  SET_FRAME_GARBAGED (selected_frame);
  return (Qt);
}


/*
 * Set the background color.
 */
DEFUN ("emacs-pc-set-default-background-color",
       Femacs_pc_set_default_background_color,
       Semacs_pc_set_default_background_color, 1, 1, 0,
       "Set the background color.  Experimental.  Do not use.")
	   (color)
	 Lisp_Object color;
{
  extern int pc_normal_attrib;
  int new_color;

  CHECK_STRING (color, 0);

  new_color = load_color (selected_frame, color, BACKGROUND_ATTRIBUTE);
  pc_normal_attrib = (pc_normal_attrib & 0x8f) | ((new_color & 0x07) << 4);
  SET_FRAME_GARBAGED (selected_frame);
  return (Qt);
}

/* Emacs initialization.  */

void
syms_of_pc_faces ()
{
  Qwindow = intern ("window");
  staticpro (&Qwindow);
  Qface = intern ("face");
  staticpro (&Qface);
  Qpriority = intern ("priority");
  staticpro (&Qpriority);

  DEFVAR_INT ("region-face", &region_face,
    "Face number to use to highlight the region\n\
The region is highlighted with this face\n\
when Transient Mark mode is enabled and the mark is active.");

  DEFVAR_LISP ("emacs-pc-translate-x11-colors",
	       &Vemacs_pc_translate_x11_colors,
   "If non-nil, attempt to translate X11 color names into a paltry PC color.");
  Vemacs_pc_translate_x11_colors = Qt;

#if 1	/* experimental foo */
  defsubr (&Semacs_pc_set_default_foreground_color);
  defsubr (&Semacs_pc_set_default_background_color);
#endif

  defsubr (&Sframe_face_alist);
  defsubr (&Sset_frame_face_alist);
  defsubr (&Smake_face_internal);
  defsubr (&Sset_face_attribute_internal);
  defsubr (&Sinternal_next_face_id);

  Qbackground_color = intern ("background-color");
  staticpro (&Qbackground_color);
  Qforeground_color = intern ("foreground-color");
  staticpro (&Qforeground_color);
  defsubr (&Sframe_parameters);
}

#endif /* PC_FACES */

