- /* Default values if we fall through.
- Actually, if that happens we should get
- window manager prompting. */
- SET_FRAME_WIDTH (f, DEFAULT_COLS);
- f->height = DEFAULT_ROWS;
- /* Window managers expect that if program-specified
- positions are not (0,0), they're intentional, not defaults. */
- f->output_data.x->top_pos = 0;
- f->output_data.x->left_pos = 0;
-
- tem0 = x_get_arg (dpyinfo, parms, Qheight, 0, 0, RES_TYPE_NUMBER);
- tem1 = x_get_arg (dpyinfo, parms, Qwidth, 0, 0, RES_TYPE_NUMBER);
- tem2 = x_get_arg (dpyinfo, parms, Quser_size, 0, 0, RES_TYPE_NUMBER);
- if (! EQ (tem0, Qunbound) || ! EQ (tem1, Qunbound))
- {
- if (!EQ (tem0, Qunbound))
- {
- CHECK_NUMBER (tem0);
- f->height = XINT (tem0);
- }
- if (!EQ (tem1, Qunbound))
- {
- CHECK_NUMBER (tem1);
- SET_FRAME_WIDTH (f, XINT (tem1));
- }
- if (!NILP (tem2) && !EQ (tem2, Qunbound))
- window_prompting |= USSize;
- else
- window_prompting |= PSize;
- }
-
- f->output_data.x->vertical_scroll_bar_extra
- = (!FRAME_HAS_VERTICAL_SCROLL_BARS (f)
- ? 0
- : (FRAME_SCROLL_BAR_COLS (f) * FONT_WIDTH (f->output_data.x->font)));
-
- x_compute_fringe_widths (f, 0);
-
- f->output_data.x->pixel_width = CHAR_TO_PIXEL_WIDTH (f, f->width);
- f->output_data.x->pixel_height = CHAR_TO_PIXEL_HEIGHT (f, f->height);
-
- tem0 = x_get_arg (dpyinfo, parms, Qtop, 0, 0, RES_TYPE_NUMBER);
- tem1 = x_get_arg (dpyinfo, parms, Qleft, 0, 0, RES_TYPE_NUMBER);
- tem2 = x_get_arg (dpyinfo, parms, Quser_position, 0, 0, RES_TYPE_NUMBER);
- if (! EQ (tem0, Qunbound) || ! EQ (tem1, Qunbound))
- {
- if (EQ (tem0, Qminus))
- {
- f->output_data.x->top_pos = 0;
- window_prompting |= YNegative;
- }
- else if (CONSP (tem0) && EQ (XCAR (tem0), Qminus)
- && CONSP (XCDR (tem0))
- && INTEGERP (XCAR (XCDR (tem0))))
- {
- f->output_data.x->top_pos = - XINT (XCAR (XCDR (tem0)));
- window_prompting |= YNegative;
- }
- else if (CONSP (tem0) && EQ (XCAR (tem0), Qplus)
- && CONSP (XCDR (tem0))
- && INTEGERP (XCAR (XCDR (tem0))))
- {
- f->output_data.x->top_pos = XINT (XCAR (XCDR (tem0)));
- }
- else if (EQ (tem0, Qunbound))
- f->output_data.x->top_pos = 0;
- else
- {
- CHECK_NUMBER (tem0);
- f->output_data.x->top_pos = XINT (tem0);
- if (f->output_data.x->top_pos < 0)
- window_prompting |= YNegative;
- }
-
- if (EQ (tem1, Qminus))
- {
- f->output_data.x->left_pos = 0;
- window_prompting |= XNegative;
- }
- else if (CONSP (tem1) && EQ (XCAR (tem1), Qminus)
- && CONSP (XCDR (tem1))
- && INTEGERP (XCAR (XCDR (tem1))))
- {
- f->output_data.x->left_pos = - XINT (XCAR (XCDR (tem1)));
- window_prompting |= XNegative;
- }
- else if (CONSP (tem1) && EQ (XCAR (tem1), Qplus)
- && CONSP (XCDR (tem1))
- && INTEGERP (XCAR (XCDR (tem1))))
- {
- f->output_data.x->left_pos = XINT (XCAR (XCDR (tem1)));
- }
- else if (EQ (tem1, Qunbound))
- f->output_data.x->left_pos = 0;
- else
- {
- CHECK_NUMBER (tem1);
- f->output_data.x->left_pos = XINT (tem1);
- if (f->output_data.x->left_pos < 0)
- window_prompting |= XNegative;
- }
-
- if (!NILP (tem2) && ! EQ (tem2, Qunbound))
- window_prompting |= USPosition;
- else
- window_prompting |= PPosition;
- }
-
- if (f->output_data.x->want_fullscreen != FULLSCREEN_NONE)
- {
- int left, top;
- int width, height;
-
- /* It takes both for some WM:s to place it where we want */
- window_prompting = USPosition | PPosition;
- x_fullscreen_adjust (f, &width, &height, &top, &left);
- f->width = width;
- f->height = height;
- f->output_data.x->pixel_width = CHAR_TO_PIXEL_WIDTH (f, f->width);
- f->output_data.x->pixel_height = CHAR_TO_PIXEL_HEIGHT (f, f->height);
- f->output_data.x->left_pos = left;
- f->output_data.x->top_pos = top;
- }
-
- return window_prompting;
-}
-
-#if !defined (HAVE_X11R4) && !defined (HAVE_XSETWMPROTOCOLS)
-
-Status
-XSetWMProtocols (dpy, w, protocols, count)
- Display *dpy;
- Window w;
- Atom *protocols;
- int count;
-{
- Atom prop;
- prop = XInternAtom (dpy, "WM_PROTOCOLS", False);
- if (prop == None) return False;
- XChangeProperty (dpy, w, prop, XA_ATOM, 32, PropModeReplace,
- (unsigned char *) protocols, count);
- return True;
-}
-#endif /* not HAVE_X11R4 && not HAVE_XSETWMPROTOCOLS */
-\f
-#ifdef USE_X_TOOLKIT
-
-/* If the WM_PROTOCOLS property does not already contain WM_TAKE_FOCUS,
- WM_DELETE_WINDOW, and WM_SAVE_YOURSELF, then add them. (They may
- already be present because of the toolkit (Motif adds some of them,
- for example, but Xt doesn't). */
-
-static void
-hack_wm_protocols (f, widget)
- FRAME_PTR f;
- Widget widget;
-{
- Display *dpy = XtDisplay (widget);
- Window w = XtWindow (widget);
- int need_delete = 1;
- int need_focus = 1;
- int need_save = 1;
-
- BLOCK_INPUT;
- {
- Atom type, *atoms = 0;
- int format = 0;
- unsigned long nitems = 0;
- unsigned long bytes_after;
-
- if ((XGetWindowProperty (dpy, w,
- FRAME_X_DISPLAY_INFO (f)->Xatom_wm_protocols,
- (long)0, (long)100, False, XA_ATOM,
- &type, &format, &nitems, &bytes_after,
- (unsigned char **) &atoms)
- == Success)
- && format == 32 && type == XA_ATOM)
- while (nitems > 0)
- {
- nitems--;
- if (atoms[nitems] == FRAME_X_DISPLAY_INFO (f)->Xatom_wm_delete_window)
- need_delete = 0;
- else if (atoms[nitems] == FRAME_X_DISPLAY_INFO (f)->Xatom_wm_take_focus)
- need_focus = 0;
- else if (atoms[nitems] == FRAME_X_DISPLAY_INFO (f)->Xatom_wm_save_yourself)
- need_save = 0;
- }
- if (atoms) XFree ((char *) atoms);
- }
- {
- Atom props [10];
- int count = 0;
- if (need_delete)
- props[count++] = FRAME_X_DISPLAY_INFO (f)->Xatom_wm_delete_window;
- if (need_focus)
- props[count++] = FRAME_X_DISPLAY_INFO (f)->Xatom_wm_take_focus;
- if (need_save)
- props[count++] = FRAME_X_DISPLAY_INFO (f)->Xatom_wm_save_yourself;
- if (count)
- XChangeProperty (dpy, w, FRAME_X_DISPLAY_INFO (f)->Xatom_wm_protocols,
- XA_ATOM, 32, PropModeAppend,
- (unsigned char *) props, count);
- }
- UNBLOCK_INPUT;
-}
-#endif
-
-
-\f
-/* Support routines for XIC (X Input Context). */
-
-#ifdef HAVE_X_I18N
-
-static XFontSet xic_create_xfontset P_ ((struct frame *, char *));
-static XIMStyle best_xim_style P_ ((XIMStyles *, XIMStyles *));
-
-
-/* Supported XIM styles, ordered by preferenc. */
-
-static XIMStyle supported_xim_styles[] =
-{
- XIMPreeditPosition | XIMStatusArea,
- XIMPreeditPosition | XIMStatusNothing,
- XIMPreeditPosition | XIMStatusNone,
- XIMPreeditNothing | XIMStatusArea,
- XIMPreeditNothing | XIMStatusNothing,
- XIMPreeditNothing | XIMStatusNone,
- XIMPreeditNone | XIMStatusArea,
- XIMPreeditNone | XIMStatusNothing,
- XIMPreeditNone | XIMStatusNone,
- 0,
-};
-
-
-/* Create an X fontset on frame F with base font name
- BASE_FONTNAME.. */
-
-static XFontSet
-xic_create_xfontset (f, base_fontname)
- struct frame *f;
- char *base_fontname;
-{
- XFontSet xfs;
- char **missing_list;
- int missing_count;
- char *def_string;
-
- xfs = XCreateFontSet (FRAME_X_DISPLAY (f),
- base_fontname, &missing_list,
- &missing_count, &def_string);
- if (missing_list)
- XFreeStringList (missing_list);
-
- /* No need to free def_string. */
- return xfs;
-}
-
-
-/* Value is the best input style, given user preferences USER (already
- checked to be supported by Emacs), and styles supported by the
- input method XIM. */
-
-static XIMStyle
-best_xim_style (user, xim)
- XIMStyles *user;
- XIMStyles *xim;
-{
- int i, j;
-
- for (i = 0; i < user->count_styles; ++i)
- for (j = 0; j < xim->count_styles; ++j)
- if (user->supported_styles[i] == xim->supported_styles[j])
- return user->supported_styles[i];
-
- /* Return the default style. */
- return XIMPreeditNothing | XIMStatusNothing;
-}
-
-/* Create XIC for frame F. */
-
-static XIMStyle xic_style;
-
-void
-create_frame_xic (f)
- struct frame *f;
-{
- XIM xim;
- XIC xic = NULL;
- XFontSet xfs = NULL;
-
- if (FRAME_XIC (f))
- return;
-
- xim = FRAME_X_XIM (f);
- if (xim)
- {
- XRectangle s_area;
- XPoint spot;
- XVaNestedList preedit_attr;
- XVaNestedList status_attr;
- char *base_fontname;
- int fontset;
-
- s_area.x = 0; s_area.y = 0; s_area.width = 1; s_area.height = 1;
- spot.x = 0; spot.y = 1;
- /* Create X fontset. */
- fontset = FRAME_FONTSET (f);
- if (fontset < 0)
- base_fontname = "-*-*-*-r-normal--14-*-*-*-*-*-*-*";
- else
- {
- /* Determine the base fontname from the ASCII font name of
- FONTSET. */
- char *ascii_font = (char *) SDATA (fontset_ascii (fontset));
- char *p = ascii_font;
- int i;
-
- for (i = 0; *p; p++)
- if (*p == '-') i++;
- if (i != 14)
- /* As the font name doesn't conform to XLFD, we can't
- modify it to get a suitable base fontname for the
- frame. */
- base_fontname = "-*-*-*-r-normal--14-*-*-*-*-*-*-*";
- else
- {
- int len = strlen (ascii_font) + 1;
- char *p1 = NULL;
-
- for (i = 0, p = ascii_font; i < 8; p++)
- {
- if (*p == '-')
- {
- i++;
- if (i == 3)
- p1 = p + 1;
- }
- }
- base_fontname = (char *) alloca (len);
- bzero (base_fontname, len);
- strcpy (base_fontname, "-*-*-");
- bcopy (p1, base_fontname + 5, p - p1);
- strcat (base_fontname, "*-*-*-*-*-*-*");
- }
- }
- xfs = xic_create_xfontset (f, base_fontname);
-
- /* Determine XIC style. */
- if (xic_style == 0)
- {
- XIMStyles supported_list;
- supported_list.count_styles = (sizeof supported_xim_styles
- / sizeof supported_xim_styles[0]);
- supported_list.supported_styles = supported_xim_styles;
- xic_style = best_xim_style (&supported_list,
- FRAME_X_XIM_STYLES (f));
- }
-
- preedit_attr = XVaCreateNestedList (0,
- XNFontSet, xfs,
- XNForeground,
- FRAME_FOREGROUND_PIXEL (f),
- XNBackground,
- FRAME_BACKGROUND_PIXEL (f),
- (xic_style & XIMPreeditPosition
- ? XNSpotLocation
- : NULL),
- &spot,
- NULL);
- status_attr = XVaCreateNestedList (0,
- XNArea,
- &s_area,
- XNFontSet,
- xfs,
- XNForeground,
- FRAME_FOREGROUND_PIXEL (f),
- XNBackground,
- FRAME_BACKGROUND_PIXEL (f),
- NULL);
-
- xic = XCreateIC (xim,
- XNInputStyle, xic_style,
- XNClientWindow, FRAME_X_WINDOW(f),
- XNFocusWindow, FRAME_X_WINDOW(f),
- XNStatusAttributes, status_attr,
- XNPreeditAttributes, preedit_attr,
- NULL);
- XFree (preedit_attr);
- XFree (status_attr);
- }
-
- FRAME_XIC (f) = xic;
- FRAME_XIC_STYLE (f) = xic_style;
- FRAME_XIC_FONTSET (f) = xfs;
-}
-
-
-/* Destroy XIC and free XIC fontset of frame F, if any. */
-
-void
-free_frame_xic (f)
- struct frame *f;
-{
- if (FRAME_XIC (f) == NULL)
- return;
-
- XDestroyIC (FRAME_XIC (f));
- if (FRAME_XIC_FONTSET (f))
- XFreeFontSet (FRAME_X_DISPLAY (f), FRAME_XIC_FONTSET (f));
-
- FRAME_XIC (f) = NULL;
- FRAME_XIC_FONTSET (f) = NULL;
-}
-
-
-/* Place preedit area for XIC of window W's frame to specified
- pixel position X/Y. X and Y are relative to window W. */
-
-void
-xic_set_preeditarea (w, x, y)
- struct window *w;
- int x, y;
-{
- struct frame *f = XFRAME (w->frame);
- XVaNestedList attr;
- XPoint spot;
-
- spot.x = WINDOW_TO_FRAME_PIXEL_X (w, x);
- spot.y = WINDOW_TO_FRAME_PIXEL_Y (w, y) + FONT_BASE (FRAME_FONT (f));
- attr = XVaCreateNestedList (0, XNSpotLocation, &spot, NULL);
- XSetICValues (FRAME_XIC (f), XNPreeditAttributes, attr, NULL);
- XFree (attr);
-}
-
-
-/* Place status area for XIC in bottom right corner of frame F.. */
-
-void
-xic_set_statusarea (f)
- struct frame *f;
-{
- XIC xic = FRAME_XIC (f);
- XVaNestedList attr;
- XRectangle area;
- XRectangle *needed;
-
- /* Negotiate geometry of status area. If input method has existing
- status area, use its current size. */
- area.x = area.y = area.width = area.height = 0;
- attr = XVaCreateNestedList (0, XNAreaNeeded, &area, NULL);
- XSetICValues (xic, XNStatusAttributes, attr, NULL);
- XFree (attr);
-
- attr = XVaCreateNestedList (0, XNAreaNeeded, &needed, NULL);
- XGetICValues (xic, XNStatusAttributes, attr, NULL);
- XFree (attr);
-
- if (needed->width == 0) /* Use XNArea instead of XNAreaNeeded */
- {
- attr = XVaCreateNestedList (0, XNArea, &needed, NULL);
- XGetICValues (xic, XNStatusAttributes, attr, NULL);
- XFree (attr);
- }
-
- area.width = needed->width;
- area.height = needed->height;
- area.x = PIXEL_WIDTH (f) - area.width - FRAME_INTERNAL_BORDER_WIDTH (f);
- area.y = (PIXEL_HEIGHT (f) - area.height
- - FRAME_MENUBAR_HEIGHT (f)
- - FRAME_TOOLBAR_HEIGHT (f)
- - FRAME_INTERNAL_BORDER_WIDTH (f));
- XFree (needed);
-
- attr = XVaCreateNestedList (0, XNArea, &area, NULL);
- XSetICValues(xic, XNStatusAttributes, attr, NULL);
- XFree (attr);
-}
-
-
-/* Set X fontset for XIC of frame F, using base font name
- BASE_FONTNAME. Called when a new Emacs fontset is chosen. */
-
-void
-xic_set_xfontset (f, base_fontname)
- struct frame *f;
- char *base_fontname;
-{
- XVaNestedList attr;
- XFontSet xfs;
-
- xfs = xic_create_xfontset (f, base_fontname);
-
- attr = XVaCreateNestedList (0, XNFontSet, xfs, NULL);
- if (FRAME_XIC_STYLE (f) & XIMPreeditPosition)
- XSetICValues (FRAME_XIC (f), XNPreeditAttributes, attr, NULL);
- if (FRAME_XIC_STYLE (f) & XIMStatusArea)
- XSetICValues (FRAME_XIC (f), XNStatusAttributes, attr, NULL);
- XFree (attr);
-
- if (FRAME_XIC_FONTSET (f))
- XFreeFontSet (FRAME_X_DISPLAY (f), FRAME_XIC_FONTSET (f));
- FRAME_XIC_FONTSET (f) = xfs;
-}
-
-#endif /* HAVE_X_I18N */
-
-
-\f
-#ifdef USE_X_TOOLKIT
-
-/* Create and set up the X widget for frame F. */
-
-static void
-x_window (f, window_prompting, minibuffer_only)
- struct frame *f;
- long window_prompting;
- int minibuffer_only;
-{
- XClassHint class_hints;
- XSetWindowAttributes attributes;
- unsigned long attribute_mask;
- Widget shell_widget;
- Widget pane_widget;
- Widget frame_widget;
- Arg al [25];
- int ac;
-
- BLOCK_INPUT;
-
- /* Use the resource name as the top-level widget name
- for looking up resources. Make a non-Lisp copy
- for the window manager, so GC relocation won't bother it.
-
- Elsewhere we specify the window name for the window manager. */
-
- {
- char *str = (char *) SDATA (Vx_resource_name);
- f->namebuf = (char *) xmalloc (strlen (str) + 1);
- strcpy (f->namebuf, str);
- }
-
- ac = 0;
- XtSetArg (al[ac], XtNallowShellResize, 1); ac++;
- XtSetArg (al[ac], XtNinput, 1); ac++;
- XtSetArg (al[ac], XtNmappedWhenManaged, 0); ac++;
- XtSetArg (al[ac], XtNborderWidth, f->output_data.x->border_width); ac++;
- XtSetArg (al[ac], XtNvisual, FRAME_X_VISUAL (f)); ac++;
- XtSetArg (al[ac], XtNdepth, FRAME_X_DISPLAY_INFO (f)->n_planes); ac++;
- XtSetArg (al[ac], XtNcolormap, FRAME_X_COLORMAP (f)); ac++;
- shell_widget = XtAppCreateShell (f->namebuf, EMACS_CLASS,
- applicationShellWidgetClass,
- FRAME_X_DISPLAY (f), al, ac);
-
- f->output_data.x->widget = shell_widget;
- /* maybe_set_screen_title_format (shell_widget); */
-
- pane_widget = lw_create_widget ("main", "pane", widget_id_tick++,
- (widget_value *) NULL,
- shell_widget, False,
- (lw_callback) NULL,
- (lw_callback) NULL,
- (lw_callback) NULL,
- (lw_callback) NULL);
-
- ac = 0;
- XtSetArg (al[ac], XtNvisual, FRAME_X_VISUAL (f)); ac++;
- XtSetArg (al[ac], XtNdepth, FRAME_X_DISPLAY_INFO (f)->n_planes); ac++;
- XtSetArg (al[ac], XtNcolormap, FRAME_X_COLORMAP (f)); ac++;
- XtSetValues (pane_widget, al, ac);
- f->output_data.x->column_widget = pane_widget;
-
- /* mappedWhenManaged to false tells to the paned window to not map/unmap
- the emacs screen when changing menubar. This reduces flickering. */
-
- ac = 0;
- XtSetArg (al[ac], XtNmappedWhenManaged, 0); ac++;
- XtSetArg (al[ac], XtNshowGrip, 0); ac++;
- XtSetArg (al[ac], XtNallowResize, 1); ac++;
- XtSetArg (al[ac], XtNresizeToPreferred, 1); ac++;
- XtSetArg (al[ac], XtNemacsFrame, f); ac++;
- XtSetArg (al[ac], XtNvisual, FRAME_X_VISUAL (f)); ac++;
- XtSetArg (al[ac], XtNdepth, FRAME_X_DISPLAY_INFO (f)->n_planes); ac++;
- XtSetArg (al[ac], XtNcolormap, FRAME_X_COLORMAP (f)); ac++;
- frame_widget = XtCreateWidget (f->namebuf, emacsFrameClass, pane_widget,
- al, ac);
-
- f->output_data.x->edit_widget = frame_widget;
-
- XtManageChild (frame_widget);
-
- /* Do some needed geometry management. */
- {
- int len;
- char *tem, shell_position[32];
- Arg al[2];
- int ac = 0;
- int extra_borders = 0;
- int menubar_size
- = (f->output_data.x->menubar_widget
- ? (f->output_data.x->menubar_widget->core.height
- + f->output_data.x->menubar_widget->core.border_width)
- : 0);
-
-#if 0 /* Experimentally, we now get the right results
- for -geometry -0-0 without this. 24 Aug 96, rms. */
- if (FRAME_EXTERNAL_MENU_BAR (f))
- {
- Dimension ibw = 0;
- XtVaGetValues (pane_widget, XtNinternalBorderWidth, &ibw, NULL);
- menubar_size += ibw;
- }
-#endif
-
- f->output_data.x->menubar_height = menubar_size;
-
-#ifndef USE_LUCID
- /* Motif seems to need this amount added to the sizes
- specified for the shell widget. The Athena/Lucid widgets don't.
- Both conclusions reached experimentally. -- rms. */
- XtVaGetValues (f->output_data.x->edit_widget, XtNinternalBorderWidth,
- &extra_borders, NULL);
- extra_borders *= 2;
-#endif
-
- /* Convert our geometry parameters into a geometry string
- and specify it.
- Note that we do not specify here whether the position
- is a user-specified or program-specified one.
- We pass that information later, in x_wm_set_size_hints. */
- {
- int left = f->output_data.x->left_pos;
- int xneg = window_prompting & XNegative;
- int top = f->output_data.x->top_pos;
- int yneg = window_prompting & YNegative;
- if (xneg)
- left = -left;
- if (yneg)
- top = -top;
-
- if (window_prompting & USPosition)
- sprintf (shell_position, "=%dx%d%c%d%c%d",
- PIXEL_WIDTH (f) + extra_borders,
- PIXEL_HEIGHT (f) + menubar_size + extra_borders,
- (xneg ? '-' : '+'), left,
- (yneg ? '-' : '+'), top);
- else
- sprintf (shell_position, "=%dx%d",
- PIXEL_WIDTH (f) + extra_borders,
- PIXEL_HEIGHT (f) + menubar_size + extra_borders);
- }
-
- len = strlen (shell_position) + 1;
- /* We don't free this because we don't know whether
- it is safe to free it while the frame exists.
- It isn't worth the trouble of arranging to free it
- when the frame is deleted. */
- tem = (char *) xmalloc (len);
- strncpy (tem, shell_position, len);
- XtSetArg (al[ac], XtNgeometry, tem); ac++;
- XtSetValues (shell_widget, al, ac);
- }
-
- XtManageChild (pane_widget);
- XtRealizeWidget (shell_widget);
-
- FRAME_X_WINDOW (f) = XtWindow (frame_widget);
-
- validate_x_resource_name ();
-
- class_hints.res_name = (char *) SDATA (Vx_resource_name);
- class_hints.res_class = (char *) SDATA (Vx_resource_class);
- XSetClassHint (FRAME_X_DISPLAY (f), XtWindow (shell_widget), &class_hints);
-
-#ifdef HAVE_X_I18N
- FRAME_XIC (f) = NULL;
-#ifdef USE_XIM
- create_frame_xic (f);
-#endif
-#endif
-
- f->output_data.x->wm_hints.input = True;
- f->output_data.x->wm_hints.flags |= InputHint;
- XSetWMHints (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f),
- &f->output_data.x->wm_hints);
-
- hack_wm_protocols (f, shell_widget);
-
-#ifdef HACK_EDITRES
- XtAddEventHandler (shell_widget, 0, True, _XEditResCheckMessages, 0);
-#endif
-
- /* Do a stupid property change to force the server to generate a
- PropertyNotify event so that the event_stream server timestamp will
- be initialized to something relevant to the time we created the window.
- */
- XChangeProperty (XtDisplay (frame_widget), XtWindow (frame_widget),
- FRAME_X_DISPLAY_INFO (f)->Xatom_wm_protocols,
- XA_ATOM, 32, PropModeAppend,
- (unsigned char*) NULL, 0);
-
- /* Make all the standard events reach the Emacs frame. */
- attributes.event_mask = STANDARD_EVENT_SET;
-
-#ifdef HAVE_X_I18N
- if (FRAME_XIC (f))
- {
- /* XIM server might require some X events. */
- unsigned long fevent = NoEventMask;
- XGetICValues(FRAME_XIC (f), XNFilterEvents, &fevent, NULL);
- attributes.event_mask |= fevent;
- }
-#endif /* HAVE_X_I18N */
-
- attribute_mask = CWEventMask;
- XChangeWindowAttributes (XtDisplay (shell_widget), XtWindow (shell_widget),
- attribute_mask, &attributes);
-
- XtMapWidget (frame_widget);
-
- /* x_set_name normally ignores requests to set the name if the
- requested name is the same as the current name. This is the one
- place where that assumption isn't correct; f->name is set, but
- the X server hasn't been told. */
- {
- Lisp_Object name;
- int explicit = f->explicit_name;
-
- f->explicit_name = 0;
- name = f->name;
- f->name = Qnil;
- x_set_name (f, name, explicit);
- }
-
- XDefineCursor (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f),
- f->output_data.x->text_cursor);
-
- UNBLOCK_INPUT;
-
- /* This is a no-op, except under Motif. Make sure main areas are
- set to something reasonable, in case we get an error later. */
- lw_set_main_areas (pane_widget, 0, frame_widget);
-}
-
-#else /* not USE_X_TOOLKIT */
-#ifdef USE_GTK
-void
-x_window (f)
- FRAME_PTR f;
-{
- if (! xg_create_frame_widgets (f))
- error ("Unable to create window");
-
-#ifdef HAVE_X_I18N
- FRAME_XIC (f) = NULL;
-#ifdef USE_XIM
- BLOCK_INPUT;
- create_frame_xic (f);
- if (FRAME_XIC (f))
- {
- /* XIM server might require some X events. */
- unsigned long fevent = NoEventMask;
- XGetICValues(FRAME_XIC (f), XNFilterEvents, &fevent, NULL);
-
- if (fevent != NoEventMask)
- {
- XSetWindowAttributes attributes;
- XWindowAttributes wattr;
- unsigned long attribute_mask;
-
- XGetWindowAttributes (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f),
- &wattr);
- attributes.event_mask = wattr.your_event_mask | fevent;
- attribute_mask = CWEventMask;
- XChangeWindowAttributes (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f),
- attribute_mask, &attributes);
- }
- }
- UNBLOCK_INPUT;
-#endif
-#endif
-}
-
-#else /*! USE_GTK */
-/* Create and set up the X window for frame F. */
-
-void
-x_window (f)
- struct frame *f;
-
-{
- XClassHint class_hints;
- XSetWindowAttributes attributes;
- unsigned long attribute_mask;
-
- attributes.background_pixel = f->output_data.x->background_pixel;
- attributes.border_pixel = f->output_data.x->border_pixel;
- attributes.bit_gravity = StaticGravity;
- attributes.backing_store = NotUseful;
- attributes.save_under = True;
- attributes.event_mask = STANDARD_EVENT_SET;
- attributes.colormap = FRAME_X_COLORMAP (f);
- attribute_mask = (CWBackPixel | CWBorderPixel | CWBitGravity | CWEventMask
- | CWColormap);
-
- BLOCK_INPUT;
- FRAME_X_WINDOW (f)
- = XCreateWindow (FRAME_X_DISPLAY (f),
- f->output_data.x->parent_desc,
- f->output_data.x->left_pos,
- f->output_data.x->top_pos,
- PIXEL_WIDTH (f), PIXEL_HEIGHT (f),
- f->output_data.x->border_width,
- CopyFromParent, /* depth */
- InputOutput, /* class */
- FRAME_X_VISUAL (f),
- attribute_mask, &attributes);
-
-#ifdef HAVE_X_I18N
-#ifdef USE_XIM
- create_frame_xic (f);
- if (FRAME_XIC (f))
- {
- /* XIM server might require some X events. */
- unsigned long fevent = NoEventMask;
- XGetICValues(FRAME_XIC (f), XNFilterEvents, &fevent, NULL);
- attributes.event_mask |= fevent;
- attribute_mask = CWEventMask;
- XChangeWindowAttributes (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f),
- attribute_mask, &attributes);
- }
-#endif
-#endif /* HAVE_X_I18N */
-
- validate_x_resource_name ();
-
- class_hints.res_name = (char *) SDATA (Vx_resource_name);
- class_hints.res_class = (char *) SDATA (Vx_resource_class);
- XSetClassHint (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), &class_hints);
-
- /* The menubar is part of the ordinary display;
- it does not count in addition to the height of the window. */
- f->output_data.x->menubar_height = 0;
-
- /* This indicates that we use the "Passive Input" input model.
- Unless we do this, we don't get the Focus{In,Out} events that we
- need to draw the cursor correctly. Accursed bureaucrats.
- XWhipsAndChains (FRAME_X_DISPLAY (f), IronMaiden, &TheRack); */
-
- f->output_data.x->wm_hints.input = True;
- f->output_data.x->wm_hints.flags |= InputHint;
- XSetWMHints (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f),
- &f->output_data.x->wm_hints);
- f->output_data.x->wm_hints.icon_pixmap = None;
-
- /* Request "save yourself" and "delete window" commands from wm. */
- {
- Atom protocols[2];
- protocols[0] = FRAME_X_DISPLAY_INFO (f)->Xatom_wm_delete_window;
- protocols[1] = FRAME_X_DISPLAY_INFO (f)->Xatom_wm_save_yourself;
- XSetWMProtocols (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), protocols, 2);
- }
-
- /* x_set_name normally ignores requests to set the name if the
- requested name is the same as the current name. This is the one
- place where that assumption isn't correct; f->name is set, but
- the X server hasn't been told. */
- {
- Lisp_Object name;
- int explicit = f->explicit_name;
-
- f->explicit_name = 0;
- name = f->name;
- f->name = Qnil;
- x_set_name (f, name, explicit);
- }
-
- XDefineCursor (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f),
- f->output_data.x->text_cursor);
-
- UNBLOCK_INPUT;
-
- if (FRAME_X_WINDOW (f) == 0)
- error ("Unable to create window");
-}
-
-#endif /* not USE_GTK */
-#endif /* not USE_X_TOOLKIT */
-
-/* Handle the icon stuff for this window. Perhaps later we might
- want an x_set_icon_position which can be called interactively as
- well. */
-
-static void
-x_icon (f, parms)
- struct frame *f;
- Lisp_Object parms;
-{
- Lisp_Object icon_x, icon_y;
- struct x_display_info *dpyinfo = FRAME_X_DISPLAY_INFO (f);
-
- /* Set the position of the icon. Note that twm groups all
- icons in an icon window. */
- icon_x = x_get_and_record_arg (f, parms, Qicon_left, 0, 0, RES_TYPE_NUMBER);
- icon_y = x_get_and_record_arg (f, parms, Qicon_top, 0, 0, RES_TYPE_NUMBER);
- if (!EQ (icon_x, Qunbound) && !EQ (icon_y, Qunbound))
- {
- CHECK_NUMBER (icon_x);
- CHECK_NUMBER (icon_y);
- }
- else if (!EQ (icon_x, Qunbound) || !EQ (icon_y, Qunbound))
- error ("Both left and top icon corners of icon must be specified");
-
- BLOCK_INPUT;
-
- if (! EQ (icon_x, Qunbound))
- x_wm_set_icon_position (f, XINT (icon_x), XINT (icon_y));
-
- /* Start up iconic or window? */
- x_wm_set_window_state
- (f, (EQ (x_get_arg (dpyinfo, parms, Qvisibility, 0, 0, RES_TYPE_SYMBOL),
- Qicon)
- ? IconicState
- : NormalState));
-
- x_text_icon (f, (char *) SDATA ((!NILP (f->icon_name)
- ? f->icon_name
- : f->name)));
-
- UNBLOCK_INPUT;
-}
-
-/* Make the GCs needed for this window, setting the
- background, border and mouse colors; also create the
- mouse cursor and the gray border tile. */
-
-static char cursor_bits[] =
- {
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00
- };
-
-static void
-x_make_gc (f)
- struct frame *f;
-{
- XGCValues gc_values;
-
- BLOCK_INPUT;
-
- /* Create the GCs of this frame.
- Note that many default values are used. */
-
- /* Normal video */
- gc_values.font = f->output_data.x->font->fid;
- gc_values.foreground = f->output_data.x->foreground_pixel;
- gc_values.background = f->output_data.x->background_pixel;
- gc_values.line_width = 0; /* Means 1 using fast algorithm. */
- f->output_data.x->normal_gc
- = XCreateGC (FRAME_X_DISPLAY (f),
- FRAME_X_WINDOW (f),
- GCLineWidth | GCFont | GCForeground | GCBackground,
- &gc_values);
-
- /* Reverse video style. */
- gc_values.foreground = f->output_data.x->background_pixel;
- gc_values.background = f->output_data.x->foreground_pixel;
- f->output_data.x->reverse_gc
- = XCreateGC (FRAME_X_DISPLAY (f),
- FRAME_X_WINDOW (f),
- GCFont | GCForeground | GCBackground | GCLineWidth,
- &gc_values);
-
- /* Cursor has cursor-color background, background-color foreground. */
- gc_values.foreground = f->output_data.x->background_pixel;
- gc_values.background = f->output_data.x->cursor_pixel;
- gc_values.fill_style = FillOpaqueStippled;
- gc_values.stipple
- = XCreateBitmapFromData (FRAME_X_DISPLAY (f),
- FRAME_X_DISPLAY_INFO (f)->root_window,
- cursor_bits, 16, 16);
- f->output_data.x->cursor_gc
- = XCreateGC (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f),
- (GCFont | GCForeground | GCBackground
- | GCFillStyle /* | GCStipple */ | GCLineWidth),
- &gc_values);
-
- /* Reliefs. */
- f->output_data.x->white_relief.gc = 0;
- f->output_data.x->black_relief.gc = 0;
-
- /* Create the gray border tile used when the pointer is not in
- the frame. Since this depends on the frame's pixel values,
- this must be done on a per-frame basis. */
- f->output_data.x->border_tile
- = (XCreatePixmapFromBitmapData
- (FRAME_X_DISPLAY (f), FRAME_X_DISPLAY_INFO (f)->root_window,
- gray_bits, gray_width, gray_height,
- f->output_data.x->foreground_pixel,
- f->output_data.x->background_pixel,
- DefaultDepth (FRAME_X_DISPLAY (f), FRAME_X_SCREEN_NUMBER (f))));
-
- UNBLOCK_INPUT;
-}
-
-
-/* Free what was was allocated in x_make_gc. */
-
-void
-x_free_gcs (f)
- struct frame *f;
-{
- Display *dpy = FRAME_X_DISPLAY (f);
-
- BLOCK_INPUT;
-
- if (f->output_data.x->normal_gc)
- {
- XFreeGC (dpy, f->output_data.x->normal_gc);
- f->output_data.x->normal_gc = 0;
- }
-
- if (f->output_data.x->reverse_gc)
- {
- XFreeGC (dpy, f->output_data.x->reverse_gc);
- f->output_data.x->reverse_gc = 0;
- }
-
- if (f->output_data.x->cursor_gc)
- {
- XFreeGC (dpy, f->output_data.x->cursor_gc);
- f->output_data.x->cursor_gc = 0;
- }
-
- if (f->output_data.x->border_tile)
- {
- XFreePixmap (dpy, f->output_data.x->border_tile);
- f->output_data.x->border_tile = 0;
- }
-
- UNBLOCK_INPUT;
-}
-
-
-/* Handler for signals raised during x_create_frame and
- x_create_top_frame. FRAME is the frame which is partially
- constructed. */
-
-static Lisp_Object
-unwind_create_frame (frame)
- Lisp_Object frame;
-{
- struct frame *f = XFRAME (frame);
-
- /* If frame is ``official'', nothing to do. */
- if (!CONSP (Vframe_list) || !EQ (XCAR (Vframe_list), frame))
- {
-#if GLYPH_DEBUG
- struct x_display_info *dpyinfo = FRAME_X_DISPLAY_INFO (f);
-#endif
-
- x_free_frame_resources (f);
-
- /* Check that reference counts are indeed correct. */
- xassert (dpyinfo->reference_count == dpyinfo_refcount);
- xassert (dpyinfo->image_cache->refcount == image_cache_refcount);
- return Qt;
- }
-
- return Qnil;
-}
-
-
-DEFUN ("x-create-frame", Fx_create_frame, Sx_create_frame,
- 1, 1, 0,
- doc: /* Make a new X window, which is called a "frame" in Emacs terms.
-Returns an Emacs frame object.
-ALIST is an alist of frame parameters.
-If the parameters specify that the frame should not have a minibuffer,
-and do not specify a specific minibuffer window to use,
-then `default-minibuffer-frame' must be a frame whose minibuffer can
-be shared by the new frame.
-
-This function is an internal primitive--use `make-frame' instead. */)
- (parms)
- Lisp_Object parms;
-{
- struct frame *f;
- Lisp_Object frame, tem;
- Lisp_Object name;
- int minibuffer_only = 0;
- long window_prompting = 0;
- int width, height;
- int count = SPECPDL_INDEX ();
- struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
- Lisp_Object display;
- struct x_display_info *dpyinfo = NULL;
- Lisp_Object parent;
- struct kboard *kb;
-
- check_x ();
-
- /* Use this general default value to start with
- until we know if this frame has a specified name. */
- Vx_resource_name = Vinvocation_name;
-
- display = x_get_arg (dpyinfo, parms, Qdisplay, 0, 0, RES_TYPE_STRING);
- if (EQ (display, Qunbound))
- display = Qnil;
- dpyinfo = check_x_display_info (display);
-#ifdef MULTI_KBOARD
- kb = dpyinfo->kboard;
-#else
- kb = &the_only_kboard;
-#endif
-
- name = x_get_arg (dpyinfo, parms, Qname, "name", "Name", RES_TYPE_STRING);
- if (!STRINGP (name)
- && ! EQ (name, Qunbound)
- && ! NILP (name))
- error ("Invalid frame name--not a string or nil");
-
- if (STRINGP (name))
- Vx_resource_name = name;
-
- /* See if parent window is specified. */
- parent = x_get_arg (dpyinfo, parms, Qparent_id, NULL, NULL, RES_TYPE_NUMBER);
- if (EQ (parent, Qunbound))
- parent = Qnil;
- if (! NILP (parent))
- CHECK_NUMBER (parent);
-
- /* make_frame_without_minibuffer can run Lisp code and garbage collect. */
- /* No need to protect DISPLAY because that's not used after passing
- it to make_frame_without_minibuffer. */
- frame = Qnil;
- GCPRO4 (parms, parent, name, frame);
- tem = x_get_arg (dpyinfo, parms, Qminibuffer, "minibuffer", "Minibuffer",
- RES_TYPE_SYMBOL);
- if (EQ (tem, Qnone) || NILP (tem))
- f = make_frame_without_minibuffer (Qnil, kb, display);
- else if (EQ (tem, Qonly))
- {
- f = make_minibuffer_frame ();
- minibuffer_only = 1;
- }
- else if (WINDOWP (tem))
- f = make_frame_without_minibuffer (tem, kb, display);
- else
- f = make_frame (1);
-
- XSETFRAME (frame, f);
-
- /* Note that X Windows does support scroll bars. */
- FRAME_CAN_HAVE_SCROLL_BARS (f) = 1;
-
- f->output_method = output_x_window;
- f->output_data.x = (struct x_output *) xmalloc (sizeof (struct x_output));
- bzero (f->output_data.x, sizeof (struct x_output));
- f->output_data.x->icon_bitmap = -1;
- f->output_data.x->fontset = -1;
- f->output_data.x->scroll_bar_foreground_pixel = -1;
- f->output_data.x->scroll_bar_background_pixel = -1;
-#ifdef USE_TOOLKIT_SCROLL_BARS
- f->output_data.x->scroll_bar_top_shadow_pixel = -1;
- f->output_data.x->scroll_bar_bottom_shadow_pixel = -1;
-#endif /* USE_TOOLKIT_SCROLL_BARS */
- record_unwind_protect (unwind_create_frame, frame);
-
- f->icon_name
- = x_get_arg (dpyinfo, parms, Qicon_name, "iconName", "Title",
- RES_TYPE_STRING);
- if (! STRINGP (f->icon_name))
- f->icon_name = Qnil;
-
- FRAME_X_DISPLAY_INFO (f) = dpyinfo;
-#if GLYPH_DEBUG
- image_cache_refcount = FRAME_X_IMAGE_CACHE (f)->refcount;
- dpyinfo_refcount = dpyinfo->reference_count;
-#endif /* GLYPH_DEBUG */
-#ifdef MULTI_KBOARD
- FRAME_KBOARD (f) = kb;
-#endif
-
- /* These colors will be set anyway later, but it's important
- to get the color reference counts right, so initialize them! */
- {
- Lisp_Object black;
- struct gcpro gcpro1;
-
- /* Function x_decode_color can signal an error. Make
- sure to initialize color slots so that we won't try
- to free colors we haven't allocated. */
- f->output_data.x->foreground_pixel = -1;
- f->output_data.x->background_pixel = -1;
- f->output_data.x->cursor_pixel = -1;
- f->output_data.x->cursor_foreground_pixel = -1;
- f->output_data.x->border_pixel = -1;
- f->output_data.x->mouse_pixel = -1;
-
- black = build_string ("black");
- GCPRO1 (black);
- f->output_data.x->foreground_pixel
- = x_decode_color (f, black, BLACK_PIX_DEFAULT (f));
- f->output_data.x->background_pixel
- = x_decode_color (f, black, BLACK_PIX_DEFAULT (f));
- f->output_data.x->cursor_pixel
- = x_decode_color (f, black, BLACK_PIX_DEFAULT (f));
- f->output_data.x->cursor_foreground_pixel
- = x_decode_color (f, black, BLACK_PIX_DEFAULT (f));
- f->output_data.x->border_pixel
- = x_decode_color (f, black, BLACK_PIX_DEFAULT (f));
- f->output_data.x->mouse_pixel
- = x_decode_color (f, black, BLACK_PIX_DEFAULT (f));
- UNGCPRO;
- }
-
- /* Specify the parent under which to make this X window. */
-
- if (!NILP (parent))
- {
- f->output_data.x->parent_desc = (Window) XFASTINT (parent);
- f->output_data.x->explicit_parent = 1;
- }
- else
- {
- f->output_data.x->parent_desc = FRAME_X_DISPLAY_INFO (f)->root_window;
- f->output_data.x->explicit_parent = 0;
- }
-
- /* Set the name; the functions to which we pass f expect the name to
- be set. */
- if (EQ (name, Qunbound) || NILP (name))
- {
- f->name = build_string (dpyinfo->x_id_name);
- f->explicit_name = 0;
- }
- else
- {
- f->name = name;
- f->explicit_name = 1;
- /* use the frame's title when getting resources for this frame. */
- specbind (Qx_resource_name, name);
- }
-
- /* Extract the window parameters from the supplied values
- that are needed to determine window geometry. */
- {
- Lisp_Object font;
-
- font = x_get_arg (dpyinfo, parms, Qfont, "font", "Font", RES_TYPE_STRING);
-
- BLOCK_INPUT;
- /* First, try whatever font the caller has specified. */
- if (STRINGP (font))
- {
- tem = Fquery_fontset (font, Qnil);
- if (STRINGP (tem))
- font = x_new_fontset (f, SDATA (tem));
- else
- font = x_new_font (f, SDATA (font));
- }
-
- /* Try out a font which we hope has bold and italic variations. */
- if (!STRINGP (font))
- font = x_new_font (f, "-adobe-courier-medium-r-*-*-*-120-*-*-*-*-iso8859-1");
- if (!STRINGP (font))
- font = x_new_font (f, "-misc-fixed-medium-r-normal-*-*-140-*-*-c-*-iso8859-1");
- if (! STRINGP (font))
- font = x_new_font (f, "-*-*-medium-r-normal-*-*-140-*-*-c-*-iso8859-1");
- if (! STRINGP (font))
- /* This was formerly the first thing tried, but it finds too many fonts
- and takes too long. */
- font = x_new_font (f, "-*-*-medium-r-*-*-*-*-*-*-c-*-iso8859-1");
- /* If those didn't work, look for something which will at least work. */
- if (! STRINGP (font))
- font = x_new_font (f, "-*-fixed-*-*-*-*-*-140-*-*-c-*-iso8859-1");
- UNBLOCK_INPUT;
- if (! STRINGP (font))
- font = build_string ("fixed");
-
- x_default_parameter (f, parms, Qfont, font,
- "font", "Font", RES_TYPE_STRING);
- }
-
-#ifdef USE_LUCID
- /* Prevent lwlib/xlwmenu.c from crashing because of a bug
- whereby it fails to get any font. */
- xlwmenu_default_font = f->output_data.x->font;
-#endif
-
- x_default_parameter (f, parms, Qborder_width, make_number (2),
- "borderWidth", "BorderWidth", RES_TYPE_NUMBER);
-
- /* This defaults to 1 in order to match xterm. We recognize either
- internalBorderWidth or internalBorder (which is what xterm calls
- it). */
- if (NILP (Fassq (Qinternal_border_width, parms)))
- {
- Lisp_Object value;
-
- value = x_get_arg (dpyinfo, parms, Qinternal_border_width,
- "internalBorder", "internalBorder", RES_TYPE_NUMBER);
- if (! EQ (value, Qunbound))
- parms = Fcons (Fcons (Qinternal_border_width, value),
- parms);
- }
- x_default_parameter (f, parms, Qinternal_border_width, make_number (1),
- "internalBorderWidth", "internalBorderWidth",
- RES_TYPE_NUMBER);
- x_default_parameter (f, parms, Qvertical_scroll_bars, Qleft,
- "verticalScrollBars", "ScrollBars",
- RES_TYPE_SYMBOL);
-
- /* Also do the stuff which must be set before the window exists. */
- x_default_parameter (f, parms, Qforeground_color, build_string ("black"),
- "foreground", "Foreground", RES_TYPE_STRING);
- x_default_parameter (f, parms, Qbackground_color, build_string ("white"),
- "background", "Background", RES_TYPE_STRING);
- x_default_parameter (f, parms, Qmouse_color, build_string ("black"),
- "pointerColor", "Foreground", RES_TYPE_STRING);
- x_default_parameter (f, parms, Qcursor_color, build_string ("black"),
- "cursorColor", "Foreground", RES_TYPE_STRING);
- x_default_parameter (f, parms, Qborder_color, build_string ("black"),
- "borderColor", "BorderColor", RES_TYPE_STRING);
- x_default_parameter (f, parms, Qscreen_gamma, Qnil,
- "screenGamma", "ScreenGamma", RES_TYPE_FLOAT);
- x_default_parameter (f, parms, Qline_spacing, Qnil,
- "lineSpacing", "LineSpacing", RES_TYPE_NUMBER);
- x_default_parameter (f, parms, Qleft_fringe, Qnil,
- "leftFringe", "LeftFringe", RES_TYPE_NUMBER);
- x_default_parameter (f, parms, Qright_fringe, Qnil,
- "rightFringe", "RightFringe", RES_TYPE_NUMBER);
-
- x_default_scroll_bar_color_parameter (f, parms, Qscroll_bar_foreground,
- "scrollBarForeground",
- "ScrollBarForeground", 1);
- x_default_scroll_bar_color_parameter (f, parms, Qscroll_bar_background,
- "scrollBarBackground",
- "ScrollBarBackground", 0);
-
- /* Init faces before x_default_parameter is called for scroll-bar
- parameters because that function calls x_set_scroll_bar_width,
- which calls change_frame_size, which calls Fset_window_buffer,
- which runs hooks, which call Fvertical_motion. At the end, we
- end up in init_iterator with a null face cache, which should not
- happen. */
- init_frame_faces (f);
-
- x_default_parameter (f, parms, Qmenu_bar_lines, make_number (1),
- "menuBar", "MenuBar", RES_TYPE_NUMBER);
- x_default_parameter (f, parms, Qtool_bar_lines, make_number (1),
- "toolBar", "ToolBar", RES_TYPE_NUMBER);
- x_default_parameter (f, parms, Qbuffer_predicate, Qnil,
- "bufferPredicate", "BufferPredicate",
- RES_TYPE_SYMBOL);
- x_default_parameter (f, parms, Qtitle, Qnil,
- "title", "Title", RES_TYPE_STRING);
- x_default_parameter (f, parms, Qwait_for_wm, Qt,
- "waitForWM", "WaitForWM", RES_TYPE_BOOLEAN);
- x_default_parameter (f, parms, Qfullscreen, Qnil,
- "fullscreen", "Fullscreen", RES_TYPE_SYMBOL);
-
- f->output_data.x->parent_desc = FRAME_X_DISPLAY_INFO (f)->root_window;
-
- /* Add the tool-bar height to the initial frame height so that the
- user gets a text display area of the size he specified with -g or
- via .Xdefaults. Later changes of the tool-bar height don't
- change the frame size. This is done so that users can create
- tall Emacs frames without having to guess how tall the tool-bar
- will get. */
- if (FRAME_TOOL_BAR_LINES (f))
- {
- int margin, relief, bar_height;
-
- relief = (tool_bar_button_relief >= 0
- ? tool_bar_button_relief
- : DEFAULT_TOOL_BAR_BUTTON_RELIEF);
-
- if (INTEGERP (Vtool_bar_button_margin)
- && XINT (Vtool_bar_button_margin) > 0)
- margin = XFASTINT (Vtool_bar_button_margin);
- else if (CONSP (Vtool_bar_button_margin)
- && INTEGERP (XCDR (Vtool_bar_button_margin))
- && XINT (XCDR (Vtool_bar_button_margin)) > 0)
- margin = XFASTINT (XCDR (Vtool_bar_button_margin));
- else
- margin = 0;
-
- bar_height = DEFAULT_TOOL_BAR_IMAGE_HEIGHT + 2 * margin + 2 * relief;
- f->height += (bar_height + CANON_Y_UNIT (f) - 1) / CANON_Y_UNIT (f);
- }
-
- /* Compute the size of the X window. */
- window_prompting = x_figure_window_size (f, parms);
-
- if (window_prompting & XNegative)
- {
- if (window_prompting & YNegative)
- f->output_data.x->win_gravity = SouthEastGravity;
- else
- f->output_data.x->win_gravity = NorthEastGravity;
- }
- else
- {
- if (window_prompting & YNegative)
- f->output_data.x->win_gravity = SouthWestGravity;
- else
- f->output_data.x->win_gravity = NorthWestGravity;
- }
-
- f->output_data.x->size_hint_flags = window_prompting;
-
- tem = x_get_arg (dpyinfo, parms, Qunsplittable, 0, 0, RES_TYPE_BOOLEAN);
- f->no_split = minibuffer_only || EQ (tem, Qt);
-
- /* Create the X widget or window. */
-#ifdef USE_X_TOOLKIT
- x_window (f, window_prompting, minibuffer_only);
-#else
- x_window (f);
-#endif
-
- x_icon (f, parms);
- x_make_gc (f);
-
- /* Now consider the frame official. */
- FRAME_X_DISPLAY_INFO (f)->reference_count++;
- Vframe_list = Fcons (frame, Vframe_list);
-
- /* We need to do this after creating the X window, so that the
- icon-creation functions can say whose icon they're describing. */
- x_default_parameter (f, parms, Qicon_type, Qnil,
- "bitmapIcon", "BitmapIcon", RES_TYPE_SYMBOL);
-
- x_default_parameter (f, parms, Qauto_raise, Qnil,
- "autoRaise", "AutoRaiseLower", RES_TYPE_BOOLEAN);
- x_default_parameter (f, parms, Qauto_lower, Qnil,
- "autoLower", "AutoRaiseLower", RES_TYPE_BOOLEAN);
- x_default_parameter (f, parms, Qcursor_type, Qbox,
- "cursorType", "CursorType", RES_TYPE_SYMBOL);
- x_default_parameter (f, parms, Qscroll_bar_width, Qnil,
- "scrollBarWidth", "ScrollBarWidth",
- RES_TYPE_NUMBER);
-
- /* Dimensions, especially f->height, must be done via change_frame_size.
- Change will not be effected unless different from the current
- f->height. */
- width = f->width;
- height = f->height;
-
- f->height = 0;
- SET_FRAME_WIDTH (f, 0);
- change_frame_size (f, height, width, 1, 0, 0);
-
- /* Set up faces after all frame parameters are known. This call
- also merges in face attributes specified for new frames. If we
- don't do this, the `menu' face for instance won't have the right
- colors, and the menu bar won't appear in the specified colors for
- new frames. */
- call1 (Qface_set_after_frame_default, frame);
-
-#if defined (USE_X_TOOLKIT) || defined (USE_GTK)
- /* Create the menu bar. */
- if (!minibuffer_only && FRAME_EXTERNAL_MENU_BAR (f))
- {
- /* If this signals an error, we haven't set size hints for the
- frame and we didn't make it visible. */
- initialize_frame_menubar (f);
-
-#ifndef USE_GTK
- /* This is a no-op, except under Motif where it arranges the
- main window for the widgets on it. */
- lw_set_main_areas (f->output_data.x->column_widget,
- f->output_data.x->menubar_widget,
- f->output_data.x->edit_widget);
-#endif /* not USE_GTK */
- }
-#endif /* USE_X_TOOLKIT || USE_GTK */
-
- /* Tell the server what size and position, etc, we want, and how
- badly we want them. This should be done after we have the menu
- bar so that its size can be taken into account. */
- BLOCK_INPUT;
- x_wm_set_size_hint (f, window_prompting, 0);
- UNBLOCK_INPUT;
-
- /* Make the window appear on the frame and enable display, unless
- the caller says not to. However, with explicit parent, Emacs
- cannot control visibility, so don't try. */
- if (! f->output_data.x->explicit_parent)
- {
- Lisp_Object visibility;
-
- visibility = x_get_arg (dpyinfo, parms, Qvisibility, 0, 0,
- RES_TYPE_SYMBOL);
- if (EQ (visibility, Qunbound))
- visibility = Qt;
-
- if (EQ (visibility, Qicon))
- x_iconify_frame (f);
- else if (! NILP (visibility))
- x_make_frame_visible (f);
- else
- /* Must have been Qnil. */
- ;
- }
-
- UNGCPRO;
-
- /* Make sure windows on this frame appear in calls to next-window
- and similar functions. */
- Vwindow_list = Qnil;
-
- return unbind_to (count, frame);
-}
-
-
-/* FRAME is used only to get a handle on the X display. We don't pass the
- display info directly because we're called from frame.c, which doesn't
- know about that structure. */
-
-Lisp_Object
-x_get_focus_frame (frame)
- struct frame *frame;
-{
- struct x_display_info *dpyinfo = FRAME_X_DISPLAY_INFO (frame);
- Lisp_Object xfocus;
- if (! dpyinfo->x_focus_frame)
- return Qnil;
-
- XSETFRAME (xfocus, dpyinfo->x_focus_frame);
- return xfocus;
-}
-
-
-/* In certain situations, when the window manager follows a
- click-to-focus policy, there seems to be no way around calling
- XSetInputFocus to give another frame the input focus .
-
- In an ideal world, XSetInputFocus should generally be avoided so
- that applications don't interfere with the window manager's focus
- policy. But I think it's okay to use when it's clearly done
- following a user-command. */
-
-DEFUN ("x-focus-frame", Fx_focus_frame, Sx_focus_frame, 1, 1, 0,
- doc: /* Set the input focus to FRAME.
-FRAME nil means use the selected frame. */)
- (frame)
- Lisp_Object frame;
-{
- struct frame *f = check_x_frame (frame);
- Display *dpy = FRAME_X_DISPLAY (f);
- int count;
-
- BLOCK_INPUT;
- count = x_catch_errors (dpy);
- XSetInputFocus (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f),
- RevertToParent, CurrentTime);
- x_uncatch_errors (dpy, count);
- UNBLOCK_INPUT;
-
- return Qnil;
-}
-
-\f
-DEFUN ("xw-color-defined-p", Fxw_color_defined_p, Sxw_color_defined_p, 1, 2, 0,
- doc: /* Internal function called by `color-defined-p', which see. */)
- (color, frame)
- Lisp_Object color, frame;
-{
- XColor foo;
- FRAME_PTR f = check_x_frame (frame);
-
- CHECK_STRING (color);
-
- if (x_defined_color (f, SDATA (color), &foo, 0))
- return Qt;
- else
- return Qnil;
-}
-
-DEFUN ("xw-color-values", Fxw_color_values, Sxw_color_values, 1, 2, 0,
- doc: /* Internal function called by `color-values', which see. */)
- (color, frame)
- Lisp_Object color, frame;
-{
- XColor foo;
- FRAME_PTR f = check_x_frame (frame);
-
- CHECK_STRING (color);
-
- if (x_defined_color (f, SDATA (color), &foo, 0))
- {
- Lisp_Object rgb[3];
-
- rgb[0] = make_number (foo.red);
- rgb[1] = make_number (foo.green);
- rgb[2] = make_number (foo.blue);
- return Flist (3, rgb);
- }
- else
- return Qnil;
-}
-
-DEFUN ("xw-display-color-p", Fxw_display_color_p, Sxw_display_color_p, 0, 1, 0,
- doc: /* Internal function called by `display-color-p', which see. */)
- (display)
- Lisp_Object display;
-{
- struct x_display_info *dpyinfo = check_x_display_info (display);
-
- if (dpyinfo->n_planes <= 2)
- return Qnil;
-
- switch (dpyinfo->visual->class)
- {
- case StaticColor:
- case PseudoColor:
- case TrueColor:
- case DirectColor:
- return Qt;
-
- default:
- return Qnil;
- }
-}
-
-DEFUN ("x-display-grayscale-p", Fx_display_grayscale_p, Sx_display_grayscale_p,
- 0, 1, 0,
- doc: /* Return t if the X display supports shades of gray.
-Note that color displays do support shades of gray.
-The optional argument DISPLAY specifies which display to ask about.
-DISPLAY should be either a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display. */)
- (display)
- Lisp_Object display;
-{
- struct x_display_info *dpyinfo = check_x_display_info (display);
-
- if (dpyinfo->n_planes <= 1)
- return Qnil;
-
- switch (dpyinfo->visual->class)
- {
- case StaticColor:
- case PseudoColor:
- case TrueColor:
- case DirectColor:
- case StaticGray:
- case GrayScale:
- return Qt;
-
- default:
- return Qnil;
- }
-}
-
-DEFUN ("x-display-pixel-width", Fx_display_pixel_width, Sx_display_pixel_width,
- 0, 1, 0,
- doc: /* Returns the width in pixels of the X display DISPLAY.
-The optional argument DISPLAY specifies which display to ask about.
-DISPLAY should be either a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display. */)
- (display)
- Lisp_Object display;
-{
- struct x_display_info *dpyinfo = check_x_display_info (display);
-
- return make_number (dpyinfo->width);
-}
-
-DEFUN ("x-display-pixel-height", Fx_display_pixel_height,
- Sx_display_pixel_height, 0, 1, 0,
- doc: /* Returns the height in pixels of the X display DISPLAY.
-The optional argument DISPLAY specifies which display to ask about.
-DISPLAY should be either a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display. */)
- (display)
- Lisp_Object display;
-{
- struct x_display_info *dpyinfo = check_x_display_info (display);
-
- return make_number (dpyinfo->height);
-}
-
-DEFUN ("x-display-planes", Fx_display_planes, Sx_display_planes,
- 0, 1, 0,
- doc: /* Returns the number of bitplanes of the X display DISPLAY.
-The optional argument DISPLAY specifies which display to ask about.
-DISPLAY should be either a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display. */)
- (display)
- Lisp_Object display;
-{
- struct x_display_info *dpyinfo = check_x_display_info (display);
-
- return make_number (dpyinfo->n_planes);
-}
-
-DEFUN ("x-display-color-cells", Fx_display_color_cells, Sx_display_color_cells,
- 0, 1, 0,
- doc: /* Returns the number of color cells of the X display DISPLAY.
-The optional argument DISPLAY specifies which display to ask about.
-DISPLAY should be either a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display. */)
- (display)
- Lisp_Object display;
-{
- struct x_display_info *dpyinfo = check_x_display_info (display);
-
- return make_number (DisplayCells (dpyinfo->display,
- XScreenNumberOfScreen (dpyinfo->screen)));
-}
-
-DEFUN ("x-server-max-request-size", Fx_server_max_request_size,
- Sx_server_max_request_size,
- 0, 1, 0,
- doc: /* Returns the maximum request size of the X server of display DISPLAY.
-The optional argument DISPLAY specifies which display to ask about.
-DISPLAY should be either a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display. */)
- (display)
- Lisp_Object display;
-{
- struct x_display_info *dpyinfo = check_x_display_info (display);
-
- return make_number (MAXREQUEST (dpyinfo->display));
-}
-
-DEFUN ("x-server-vendor", Fx_server_vendor, Sx_server_vendor, 0, 1, 0,
- doc: /* Returns the vendor ID string of the X server of display DISPLAY.
-The optional argument DISPLAY specifies which display to ask about.
-DISPLAY should be either a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display. */)
- (display)
- Lisp_Object display;
-{
- struct x_display_info *dpyinfo = check_x_display_info (display);
- char *vendor = ServerVendor (dpyinfo->display);
-
- if (! vendor) vendor = "";
- return build_string (vendor);
-}
-
-DEFUN ("x-server-version", Fx_server_version, Sx_server_version, 0, 1, 0,
- doc: /* Returns the version numbers of the X server of display DISPLAY.
-The value is a list of three integers: the major and minor
-version numbers of the X Protocol in use, and the vendor-specific release
-number. See also the function `x-server-vendor'.
-
-The optional argument DISPLAY specifies which display to ask about.
-DISPLAY should be either a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display. */)
- (display)
- Lisp_Object display;
-{
- struct x_display_info *dpyinfo = check_x_display_info (display);
- Display *dpy = dpyinfo->display;
-
- return Fcons (make_number (ProtocolVersion (dpy)),
- Fcons (make_number (ProtocolRevision (dpy)),
- Fcons (make_number (VendorRelease (dpy)), Qnil)));
-}
-
-DEFUN ("x-display-screens", Fx_display_screens, Sx_display_screens, 0, 1, 0,
- doc: /* Return the number of screens on the X server of display DISPLAY.
-The optional argument DISPLAY specifies which display to ask about.
-DISPLAY should be either a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display. */)
- (display)
- Lisp_Object display;
-{
- struct x_display_info *dpyinfo = check_x_display_info (display);
-
- return make_number (ScreenCount (dpyinfo->display));
-}
-
-DEFUN ("x-display-mm-height", Fx_display_mm_height, Sx_display_mm_height, 0, 1, 0,
- doc: /* Return the height in millimeters of the X display DISPLAY.
-The optional argument DISPLAY specifies which display to ask about.
-DISPLAY should be either a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display. */)
- (display)
- Lisp_Object display;
-{
- struct x_display_info *dpyinfo = check_x_display_info (display);
-
- return make_number (HeightMMOfScreen (dpyinfo->screen));
-}
-
-DEFUN ("x-display-mm-width", Fx_display_mm_width, Sx_display_mm_width, 0, 1, 0,
- doc: /* Return the width in millimeters of the X display DISPLAY.
-The optional argument DISPLAY specifies which display to ask about.
-DISPLAY should be either a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display. */)
- (display)
- Lisp_Object display;
-{
- struct x_display_info *dpyinfo = check_x_display_info (display);
-
- return make_number (WidthMMOfScreen (dpyinfo->screen));
-}
-
-DEFUN ("x-display-backing-store", Fx_display_backing_store,
- Sx_display_backing_store, 0, 1, 0,
- doc: /* Returns an indication of whether X display DISPLAY does backing store.
-The value may be `always', `when-mapped', or `not-useful'.
-The optional argument DISPLAY specifies which display to ask about.
-DISPLAY should be either a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display. */)
- (display)
- Lisp_Object display;
-{
- struct x_display_info *dpyinfo = check_x_display_info (display);
- Lisp_Object result;
-
- switch (DoesBackingStore (dpyinfo->screen))
- {
- case Always:
- result = intern ("always");
- break;
-
- case WhenMapped:
- result = intern ("when-mapped");
- break;
-
- case NotUseful:
- result = intern ("not-useful");
- break;
-
- default:
- error ("Strange value for BackingStore parameter of screen");
- result = Qnil;
- }
-
- return result;
-}
-
-DEFUN ("x-display-visual-class", Fx_display_visual_class,
- Sx_display_visual_class, 0, 1, 0,
- doc: /* Return the visual class of the X display DISPLAY.
-The value is one of the symbols `static-gray', `gray-scale',
-`static-color', `pseudo-color', `true-color', or `direct-color'.
-
-The optional argument DISPLAY specifies which display to ask about.
-DISPLAY should be either a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display. */)
- (display)
- Lisp_Object display;
-{
- struct x_display_info *dpyinfo = check_x_display_info (display);
- Lisp_Object result;
-
- switch (dpyinfo->visual->class)
- {
- case StaticGray:
- result = intern ("static-gray");
- break;
- case GrayScale:
- result = intern ("gray-scale");
- break;
- case StaticColor:
- result = intern ("static-color");
- break;
- case PseudoColor:
- result = intern ("pseudo-color");
- break;
- case TrueColor:
- result = intern ("true-color");
- break;
- case DirectColor:
- result = intern ("direct-color");
- break;
- default:
- error ("Display has an unknown visual class");
- result = Qnil;
- }
-
- return result;
-}
-
-DEFUN ("x-display-save-under", Fx_display_save_under,
- Sx_display_save_under, 0, 1, 0,
- doc: /* Returns t if the X display DISPLAY supports the save-under feature.
-The optional argument DISPLAY specifies which display to ask about.
-DISPLAY should be either a frame or a display name (a string).
-If omitted or nil, that stands for the selected frame's display. */)
- (display)
- Lisp_Object display;
-{
- struct x_display_info *dpyinfo = check_x_display_info (display);
-
- if (DoesSaveUnders (dpyinfo->screen) == True)
- return Qt;
- else
- return Qnil;
-}
-\f
-int
-x_pixel_width (f)
- register struct frame *f;
-{
- return PIXEL_WIDTH (f);
-}
-
-int
-x_pixel_height (f)
- register struct frame *f;
-{
- return PIXEL_HEIGHT (f);
-}
-
-int
-x_char_width (f)
- register struct frame *f;
-{
- return FONT_WIDTH (f->output_data.x->font);
-}
-
-int
-x_char_height (f)
- register struct frame *f;
-{
- return f->output_data.x->line_height;
-}
-
-int
-x_screen_planes (f)
- register struct frame *f;
-{
- return FRAME_X_DISPLAY_INFO (f)->n_planes;
-}
-
-
-\f
-/************************************************************************
- X Displays
- ************************************************************************/
-
-\f
-/* Mapping visual names to visuals. */
-
-static struct visual_class
-{
- char *name;
- int class;
-}
-visual_classes[] =
-{
- {"StaticGray", StaticGray},
- {"GrayScale", GrayScale},
- {"StaticColor", StaticColor},
- {"PseudoColor", PseudoColor},
- {"TrueColor", TrueColor},
- {"DirectColor", DirectColor},
- {NULL, 0}
-};
-
-
-#ifndef HAVE_XSCREENNUMBEROFSCREEN
-
-/* Value is the screen number of screen SCR. This is a substitute for
- the X function with the same name when that doesn't exist. */
-
-int
-XScreenNumberOfScreen (scr)
- register Screen *scr;
-{
- Display *dpy = scr->display;
- int i;
-
- for (i = 0; i < dpy->nscreens; ++i)
- if (scr == dpy->screens + i)
- break;
-
- return i;
-}
-
-#endif /* not HAVE_XSCREENNUMBEROFSCREEN */
-
-
-/* Select the visual that should be used on display DPYINFO. Set
- members of DPYINFO appropriately. Called from x_term_init. */
-
-void
-select_visual (dpyinfo)
- struct x_display_info *dpyinfo;
-{
- Display *dpy = dpyinfo->display;
- Screen *screen = dpyinfo->screen;
- Lisp_Object value;
-
- /* See if a visual is specified. */
- value = display_x_get_resource (dpyinfo,
- build_string ("visualClass"),
- build_string ("VisualClass"),
- Qnil, Qnil);
- if (STRINGP (value))
- {
- /* VALUE should be of the form CLASS-DEPTH, where CLASS is one
- of `PseudoColor', `TrueColor' etc. and DEPTH is the color
- depth, a decimal number. NAME is compared with case ignored. */
- char *s = (char *) alloca (SBYTES (value) + 1);
- char *dash;
- int i, class = -1;
- XVisualInfo vinfo;
-
- strcpy (s, SDATA (value));
- dash = index (s, '-');
- if (dash)
- {
- dpyinfo->n_planes = atoi (dash + 1);
- *dash = '\0';
- }
- else
- /* We won't find a matching visual with depth 0, so that
- an error will be printed below. */
- dpyinfo->n_planes = 0;
-
- /* Determine the visual class. */
- for (i = 0; visual_classes[i].name; ++i)
- if (xstricmp (s, visual_classes[i].name) == 0)
- {
- class = visual_classes[i].class;
- break;
- }
-
- /* Look up a matching visual for the specified class. */
- if (class == -1
- || !XMatchVisualInfo (dpy, XScreenNumberOfScreen (screen),
- dpyinfo->n_planes, class, &vinfo))
- fatal ("Invalid visual specification `%s'", SDATA (value));
-
- dpyinfo->visual = vinfo.visual;
- }
- else
- {
- int n_visuals;
- XVisualInfo *vinfo, vinfo_template;
-
- dpyinfo->visual = DefaultVisualOfScreen (screen);
-
-#ifdef HAVE_X11R4
- vinfo_template.visualid = XVisualIDFromVisual (dpyinfo->visual);
-#else
- vinfo_template.visualid = dpyinfo->visual->visualid;
-#endif
- vinfo_template.screen = XScreenNumberOfScreen (screen);
- vinfo = XGetVisualInfo (dpy, VisualIDMask | VisualScreenMask,
- &vinfo_template, &n_visuals);
- if (n_visuals != 1)
- fatal ("Can't get proper X visual info");
-
- dpyinfo->n_planes = vinfo->depth;
- XFree ((char *) vinfo);
- }
-}
-
-
-/* Return the X display structure for the display named NAME.
- Open a new connection if necessary. */
-
-struct x_display_info *
-x_display_info_for_name (name)
- Lisp_Object name;
-{
- Lisp_Object names;
- struct x_display_info *dpyinfo;
-
- CHECK_STRING (name);
-
- if (! EQ (Vwindow_system, intern ("x")))
- error ("Not using X Windows");
-
- for (dpyinfo = x_display_list, names = x_display_name_list;
- dpyinfo;
- dpyinfo = dpyinfo->next, names = XCDR (names))
- {
- Lisp_Object tem;
- tem = Fstring_equal (XCAR (XCAR (names)), name);
- if (!NILP (tem))
- return dpyinfo;
- }
-
- /* Use this general default value to start with. */
- Vx_resource_name = Vinvocation_name;
-
- validate_x_resource_name ();
-
- dpyinfo = x_term_init (name, (char *)0,
- (char *) SDATA (Vx_resource_name));
-
- if (dpyinfo == 0)
- error ("Cannot connect to X server %s", SDATA (name));
-
- x_in_use = 1;
- XSETFASTINT (Vwindow_system_version, 11);
-
- return dpyinfo;
-}
-
-
-DEFUN ("x-open-connection", Fx_open_connection, Sx_open_connection,
- 1, 3, 0,
- doc: /* Open a connection to an X server.
-DISPLAY is the name of the display to connect to.
-Optional second arg XRM-STRING is a string of resources in xrdb format.
-If the optional third arg MUST-SUCCEED is non-nil,
-terminate Emacs if we can't open the connection. */)
- (display, xrm_string, must_succeed)
- Lisp_Object display, xrm_string, must_succeed;
-{
- unsigned char *xrm_option;
- struct x_display_info *dpyinfo;
-
- CHECK_STRING (display);
- if (! NILP (xrm_string))
- CHECK_STRING (xrm_string);
-
- if (! EQ (Vwindow_system, intern ("x")))
- error ("Not using X Windows");
-
- if (! NILP (xrm_string))
- xrm_option = (unsigned char *) SDATA (xrm_string);
- else
- xrm_option = (unsigned char *) 0;
-
- validate_x_resource_name ();
-
- /* This is what opens the connection and sets x_current_display.
- This also initializes many symbols, such as those used for input. */
- dpyinfo = x_term_init (display, xrm_option,
- (char *) SDATA (Vx_resource_name));
-
- if (dpyinfo == 0)
- {
- if (!NILP (must_succeed))
- fatal ("Cannot connect to X server %s.\n\
-Check the DISPLAY environment variable or use `-d'.\n\
-Also use the `xauth' program to verify that you have the proper\n\
-authorization information needed to connect the X server.\n\
-An insecure way to solve the problem may be to use `xhost'.\n",
- SDATA (display));
- else
- error ("Cannot connect to X server %s", SDATA (display));
- }
-
- x_in_use = 1;
-
- XSETFASTINT (Vwindow_system_version, 11);
- return Qnil;
-}
-
-DEFUN ("x-close-connection", Fx_close_connection,
- Sx_close_connection, 1, 1, 0,
- doc: /* Close the connection to DISPLAY's X server.
-For DISPLAY, specify either a frame or a display name (a string).
-If DISPLAY is nil, that stands for the selected frame's display. */)
- (display)
- Lisp_Object display;
-{
- struct x_display_info *dpyinfo = check_x_display_info (display);
- int i;
-
- if (dpyinfo->reference_count > 0)
- error ("Display still has frames on it");
-
- BLOCK_INPUT;
- /* Free the fonts in the font table. */
- for (i = 0; i < dpyinfo->n_fonts; i++)
- if (dpyinfo->font_table[i].name)
- {
- if (dpyinfo->font_table[i].name != dpyinfo->font_table[i].full_name)
- xfree (dpyinfo->font_table[i].full_name);
- xfree (dpyinfo->font_table[i].name);
- XFreeFont (dpyinfo->display, dpyinfo->font_table[i].font);
- }
-
- x_destroy_all_bitmaps (dpyinfo);
- XSetCloseDownMode (dpyinfo->display, DestroyAll);
-
-#ifdef USE_X_TOOLKIT
- XtCloseDisplay (dpyinfo->display);
-#else
- XCloseDisplay (dpyinfo->display);
-#endif
-
- x_delete_display (dpyinfo);
- UNBLOCK_INPUT;
-
- return Qnil;
-}
-
-DEFUN ("x-display-list", Fx_display_list, Sx_display_list, 0, 0, 0,
- doc: /* Return the list of display names that Emacs has connections to. */)
- ()
-{
- Lisp_Object tail, result;
-
- result = Qnil;
- for (tail = x_display_name_list; ! NILP (tail); tail = XCDR (tail))
- result = Fcons (XCAR (XCAR (tail)), result);
-
- return result;
-}
-
-DEFUN ("x-synchronize", Fx_synchronize, Sx_synchronize, 1, 2, 0,
- doc: /* If ON is non-nil, report X errors as soon as the erring request is made.
-If ON is nil, allow buffering of requests.
-Turning on synchronization prohibits the Xlib routines from buffering
-requests and seriously degrades performance, but makes debugging much
-easier.
-The optional second argument DISPLAY specifies which display to act on.
-DISPLAY should be either a frame or a display name (a string).
-If DISPLAY is omitted or nil, that stands for the selected frame's display. */)
- (on, display)
- Lisp_Object display, on;
-{
- struct x_display_info *dpyinfo = check_x_display_info (display);
-
- XSynchronize (dpyinfo->display, !EQ (on, Qnil));
-
- return Qnil;
-}
-
-/* Wait for responses to all X commands issued so far for frame F. */
-
-void
-x_sync (f)
- FRAME_PTR f;
-{
- BLOCK_INPUT;
- XSync (FRAME_X_DISPLAY (f), False);
- UNBLOCK_INPUT;
-}
-
-\f
-/***********************************************************************
- Image types
- ***********************************************************************/
-
-/* Value is the number of elements of vector VECTOR. */
-
-#define DIM(VECTOR) (sizeof (VECTOR) / sizeof *(VECTOR))
-
-/* List of supported image types. Use define_image_type to add new
- types. Use lookup_image_type to find a type for a given symbol. */
-
-static struct image_type *image_types;
-
-/* The symbol `image' which is the car of the lists used to represent
- images in Lisp. */
-
-extern Lisp_Object Qimage;
-
-/* The symbol `xbm' which is used as the type symbol for XBM images. */
-
-Lisp_Object Qxbm;
-
-/* Keywords. */
-
-extern Lisp_Object QCwidth, QCheight, QCforeground, QCbackground, QCfile;
-extern Lisp_Object QCdata, QCtype;
-Lisp_Object QCascent, QCmargin, QCrelief;
-Lisp_Object QCconversion, QCcolor_symbols, QCheuristic_mask;
-Lisp_Object QCindex, QCmatrix, QCcolor_adjustment, QCmask;
-
-/* Other symbols. */
-
-Lisp_Object Qlaplace, Qemboss, Qedge_detection, Qheuristic;
-
-/* Time in seconds after which images should be removed from the cache
- if not displayed. */
-
-Lisp_Object Vimage_cache_eviction_delay;
-
-/* Function prototypes. */
-
-static void define_image_type P_ ((struct image_type *type));
-static struct image_type *lookup_image_type P_ ((Lisp_Object symbol));
-static void image_error P_ ((char *format, Lisp_Object, Lisp_Object));
-static void x_laplace P_ ((struct frame *, struct image *));
-static void x_emboss P_ ((struct frame *, struct image *));
-static int x_build_heuristic_mask P_ ((struct frame *, struct image *,
- Lisp_Object));
-
-
-/* Define a new image type from TYPE. This adds a copy of TYPE to
- image_types and adds the symbol *TYPE->type to Vimage_types. */
-
-static void
-define_image_type (type)
- struct image_type *type;
-{
- /* Make a copy of TYPE to avoid a bus error in a dumped Emacs.
- The initialized data segment is read-only. */
- struct image_type *p = (struct image_type *) xmalloc (sizeof *p);
- bcopy (type, p, sizeof *p);
- p->next = image_types;
- image_types = p;
- Vimage_types = Fcons (*p->type, Vimage_types);
-}
-
-
-/* Look up image type SYMBOL, and return a pointer to its image_type
- structure. Value is null if SYMBOL is not a known image type. */
-
-static INLINE struct image_type *
-lookup_image_type (symbol)
- Lisp_Object symbol;
-{
- struct image_type *type;
-
- for (type = image_types; type; type = type->next)
- if (EQ (symbol, *type->type))
- break;
-
- return type;
-}
-
-
-/* Value is non-zero if OBJECT is a valid Lisp image specification. A
- valid image specification is a list whose car is the symbol
- `image', and whose rest is a property list. The property list must
- contain a value for key `:type'. That value must be the name of a
- supported image type. The rest of the property list depends on the
- image type. */
-
-int
-valid_image_p (object)
- Lisp_Object object;
-{
- int valid_p = 0;
-
- if (CONSP (object) && EQ (XCAR (object), Qimage))
- {
- Lisp_Object tem;
-
- for (tem = XCDR (object); CONSP (tem); tem = XCDR (tem))
- if (EQ (XCAR (tem), QCtype))
- {
- tem = XCDR (tem);
- if (CONSP (tem) && SYMBOLP (XCAR (tem)))
- {
- struct image_type *type;
- type = lookup_image_type (XCAR (tem));
- if (type)
- valid_p = type->valid_p (object);
- }
-
- break;
- }
- }
-
- return valid_p;
-}
-
-
-/* Log error message with format string FORMAT and argument ARG.
- Signaling an error, e.g. when an image cannot be loaded, is not a
- good idea because this would interrupt redisplay, and the error
- message display would lead to another redisplay. This function
- therefore simply displays a message. */
-
-static void
-image_error (format, arg1, arg2)
- char *format;
- Lisp_Object arg1, arg2;
-{
- add_to_log (format, arg1, arg2);
-}
-
-
-\f
-/***********************************************************************
- Image specifications
- ***********************************************************************/
-
-enum image_value_type
-{
- IMAGE_DONT_CHECK_VALUE_TYPE,
- IMAGE_STRING_VALUE,
- IMAGE_STRING_OR_NIL_VALUE,
- IMAGE_SYMBOL_VALUE,
- IMAGE_POSITIVE_INTEGER_VALUE,
- IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR,
- IMAGE_NON_NEGATIVE_INTEGER_VALUE,
- IMAGE_ASCENT_VALUE,
- IMAGE_INTEGER_VALUE,
- IMAGE_FUNCTION_VALUE,
- IMAGE_NUMBER_VALUE,
- IMAGE_BOOL_VALUE
-};
-
-/* Structure used when parsing image specifications. */
-
-struct image_keyword
-{
- /* Name of keyword. */
- char *name;
-
- /* The type of value allowed. */
- enum image_value_type type;
-
- /* Non-zero means key must be present. */
- int mandatory_p;
-
- /* Used to recognize duplicate keywords in a property list. */
- int count;
-
- /* The value that was found. */
- Lisp_Object value;
-};
-
-
-static int parse_image_spec P_ ((Lisp_Object, struct image_keyword *,
- int, Lisp_Object));
-static Lisp_Object image_spec_value P_ ((Lisp_Object, Lisp_Object, int *));
-
-
-/* Parse image spec SPEC according to KEYWORDS. A valid image spec
- has the format (image KEYWORD VALUE ...). One of the keyword/
- value pairs must be `:type TYPE'. KEYWORDS is a vector of
- image_keywords structures of size NKEYWORDS describing other
- allowed keyword/value pairs. Value is non-zero if SPEC is valid. */
-
-static int
-parse_image_spec (spec, keywords, nkeywords, type)
- Lisp_Object spec;
- struct image_keyword *keywords;
- int nkeywords;
- Lisp_Object type;
-{
- int i;
- Lisp_Object plist;
-
- if (!CONSP (spec) || !EQ (XCAR (spec), Qimage))
- return 0;
-
- plist = XCDR (spec);
- while (CONSP (plist))
- {
- Lisp_Object key, value;
-
- /* First element of a pair must be a symbol. */
- key = XCAR (plist);
- plist = XCDR (plist);
- if (!SYMBOLP (key))
- return 0;
-
- /* There must follow a value. */
- if (!CONSP (plist))
- return 0;
- value = XCAR (plist);
- plist = XCDR (plist);
-
- /* Find key in KEYWORDS. Error if not found. */
- for (i = 0; i < nkeywords; ++i)
- if (strcmp (keywords[i].name, SDATA (SYMBOL_NAME (key))) == 0)
- break;
-
- if (i == nkeywords)
- continue;
-
- /* Record that we recognized the keyword. If a keywords
- was found more than once, it's an error. */
- keywords[i].value = value;
- ++keywords[i].count;
-
- if (keywords[i].count > 1)
- return 0;
-
- /* Check type of value against allowed type. */
- switch (keywords[i].type)
- {
- case IMAGE_STRING_VALUE:
- if (!STRINGP (value))
- return 0;
- break;
-
- case IMAGE_STRING_OR_NIL_VALUE:
- if (!STRINGP (value) && !NILP (value))
- return 0;
- break;
-
- case IMAGE_SYMBOL_VALUE:
- if (!SYMBOLP (value))
- return 0;
- break;
-
- case IMAGE_POSITIVE_INTEGER_VALUE:
- if (!INTEGERP (value) || XINT (value) <= 0)
- return 0;
- break;
-
- case IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR:
- if (INTEGERP (value) && XINT (value) >= 0)
- break;
- if (CONSP (value)
- && INTEGERP (XCAR (value)) && INTEGERP (XCDR (value))
- && XINT (XCAR (value)) >= 0 && XINT (XCDR (value)) >= 0)
- break;
- return 0;
-
- case IMAGE_ASCENT_VALUE:
- if (SYMBOLP (value) && EQ (value, Qcenter))
- break;
- else if (INTEGERP (value)
- && XINT (value) >= 0
- && XINT (value) <= 100)
- break;
- return 0;
-
- case IMAGE_NON_NEGATIVE_INTEGER_VALUE:
- if (!INTEGERP (value) || XINT (value) < 0)
- return 0;
- break;
-
- case IMAGE_DONT_CHECK_VALUE_TYPE:
- break;
-
- case IMAGE_FUNCTION_VALUE:
- value = indirect_function (value);
- if (SUBRP (value)
- || COMPILEDP (value)
- || (CONSP (value) && EQ (XCAR (value), Qlambda)))
- break;
- return 0;
-
- case IMAGE_NUMBER_VALUE:
- if (!INTEGERP (value) && !FLOATP (value))
- return 0;
- break;
-
- case IMAGE_INTEGER_VALUE:
- if (!INTEGERP (value))
- return 0;
- break;
-
- case IMAGE_BOOL_VALUE:
- if (!NILP (value) && !EQ (value, Qt))
- return 0;
- break;
-
- default:
- abort ();
- break;
- }
-
- if (EQ (key, QCtype) && !EQ (type, value))
- return 0;
- }
-
- /* Check that all mandatory fields are present. */
- for (i = 0; i < nkeywords; ++i)
- if (keywords[i].mandatory_p && keywords[i].count == 0)
- return 0;
-
- return NILP (plist);
-}
-
-
-/* Return the value of KEY in image specification SPEC. Value is nil
- if KEY is not present in SPEC. if FOUND is not null, set *FOUND
- to 1 if KEY was found in SPEC, set it to 0 otherwise. */
-
-static Lisp_Object
-image_spec_value (spec, key, found)
- Lisp_Object spec, key;
- int *found;
-{
- Lisp_Object tail;
-
- xassert (valid_image_p (spec));
-
- for (tail = XCDR (spec);
- CONSP (tail) && CONSP (XCDR (tail));
- tail = XCDR (XCDR (tail)))
- {
- if (EQ (XCAR (tail), key))
- {
- if (found)
- *found = 1;
- return XCAR (XCDR (tail));
- }
- }
-
- if (found)
- *found = 0;
- return Qnil;
-}
-
-
-DEFUN ("image-size", Fimage_size, Simage_size, 1, 3, 0,
- doc: /* Return the size of image SPEC as pair (WIDTH . HEIGHT).
-PIXELS non-nil means return the size in pixels, otherwise return the
-size in canonical character units.
-FRAME is the frame on which the image will be displayed. FRAME nil
-or omitted means use the selected frame. */)
- (spec, pixels, frame)
- Lisp_Object spec, pixels, frame;
-{
- Lisp_Object size;
-
- size = Qnil;
- if (valid_image_p (spec))
- {
- struct frame *f = check_x_frame (frame);
- int id = lookup_image (f, spec);
- struct image *img = IMAGE_FROM_ID (f, id);
- int width = img->width + 2 * img->hmargin;
- int height = img->height + 2 * img->vmargin;
-
- if (NILP (pixels))
- size = Fcons (make_float ((double) width / CANON_X_UNIT (f)),
- make_float ((double) height / CANON_Y_UNIT (f)));
- else
- size = Fcons (make_number (width), make_number (height));
- }
- else
- error ("Invalid image specification");
-
- return size;
-}
-
-
-DEFUN ("image-mask-p", Fimage_mask_p, Simage_mask_p, 1, 2, 0,
- doc: /* Return t if image SPEC has a mask bitmap.
-FRAME is the frame on which the image will be displayed. FRAME nil
-or omitted means use the selected frame. */)
- (spec, frame)
- Lisp_Object spec, frame;
-{
- Lisp_Object mask;
-
- mask = Qnil;
- if (valid_image_p (spec))
- {
- struct frame *f = check_x_frame (frame);
- int id = lookup_image (f, spec);
- struct image *img = IMAGE_FROM_ID (f, id);
- if (img->mask)
- mask = Qt;
- }
- else
- error ("Invalid image specification");
-
- return mask;
-}
-
-
-\f
-/***********************************************************************
- Image type independent image structures
- ***********************************************************************/
-
-static struct image *make_image P_ ((Lisp_Object spec, unsigned hash));
-static void free_image P_ ((struct frame *f, struct image *img));
-
-
-/* Allocate and return a new image structure for image specification
- SPEC. SPEC has a hash value of HASH. */
-
-static struct image *
-make_image (spec, hash)
- Lisp_Object spec;
- unsigned hash;
-{
- struct image *img = (struct image *) xmalloc (sizeof *img);
-
- xassert (valid_image_p (spec));
- bzero (img, sizeof *img);
- img->type = lookup_image_type (image_spec_value (spec, QCtype, NULL));
- xassert (img->type != NULL);
- img->spec = spec;
- img->data.lisp_val = Qnil;
- img->ascent = DEFAULT_IMAGE_ASCENT;
- img->hash = hash;
- return img;
-}
-
-
-/* Free image IMG which was used on frame F, including its resources. */
-
-static void
-free_image (f, img)
- struct frame *f;
- struct image *img;
-{
- if (img)
- {
- struct image_cache *c = FRAME_X_IMAGE_CACHE (f);
-
- /* Remove IMG from the hash table of its cache. */
- if (img->prev)
- img->prev->next = img->next;
- else
- c->buckets[img->hash % IMAGE_CACHE_BUCKETS_SIZE] = img->next;
-
- if (img->next)
- img->next->prev = img->prev;
-
- c->images[img->id] = NULL;
-
- /* Free resources, then free IMG. */
- img->type->free (f, img);
- xfree (img);
- }
-}
-
-
-/* Prepare image IMG for display on frame F. Must be called before
- drawing an image. */
-
-void
-prepare_image_for_display (f, img)
- struct frame *f;
- struct image *img;
-{
- EMACS_TIME t;
-
- /* We're about to display IMG, so set its timestamp to `now'. */
- EMACS_GET_TIME (t);
- img->timestamp = EMACS_SECS (t);
-
- /* If IMG doesn't have a pixmap yet, load it now, using the image
- type dependent loader function. */
- if (img->pixmap == None && !img->load_failed_p)
- img->load_failed_p = img->type->load (f, img) == 0;
-}
-
-
-/* Value is the number of pixels for the ascent of image IMG when
- drawn in face FACE. */
-
-int
-image_ascent (img, face)
- struct image *img;
- struct face *face;
-{
- int height = img->height + img->vmargin;
- int ascent;
-
- if (img->ascent == CENTERED_IMAGE_ASCENT)
- {
- if (face->font)
- /* This expression is arranged so that if the image can't be
- exactly centered, it will be moved slightly up. This is
- because a typical font is `top-heavy' (due to the presence
- uppercase letters), so the image placement should err towards
- being top-heavy too. It also just generally looks better. */
- ascent = (height + face->font->ascent - face->font->descent + 1) / 2;
- else
- ascent = height / 2;
- }
- else
- ascent = height * img->ascent / 100.0;
-
- return ascent;
-}
-
-\f
-/* Image background colors. */
-
-static unsigned long
-four_corners_best (ximg, width, height)
- XImage *ximg;
- unsigned long width, height;
-{
- unsigned long corners[4], best;
- int i, best_count;
-
- /* Get the colors at the corners of ximg. */
- corners[0] = XGetPixel (ximg, 0, 0);
- corners[1] = XGetPixel (ximg, width - 1, 0);
- corners[2] = XGetPixel (ximg, width - 1, height - 1);
- corners[3] = XGetPixel (ximg, 0, height - 1);
-
- /* Choose the most frequently found color as background. */
- for (i = best_count = 0; i < 4; ++i)
- {
- int j, n;
-
- for (j = n = 0; j < 4; ++j)
- if (corners[i] == corners[j])
- ++n;
-
- if (n > best_count)
- best = corners[i], best_count = n;
- }
-
- return best;
-}
-
-/* Return the `background' field of IMG. If IMG doesn't have one yet,
- it is guessed heuristically. If non-zero, XIMG is an existing XImage
- object to use for the heuristic. */
-
-unsigned long
-image_background (img, f, ximg)
- struct image *img;
- struct frame *f;
- XImage *ximg;
-{
- if (! img->background_valid)
- /* IMG doesn't have a background yet, try to guess a reasonable value. */
- {
- int free_ximg = !ximg;
-
- if (! ximg)
- ximg = XGetImage (FRAME_X_DISPLAY (f), img->pixmap,
- 0, 0, img->width, img->height, ~0, ZPixmap);
-
- img->background = four_corners_best (ximg, img->width, img->height);
-
- if (free_ximg)
- XDestroyImage (ximg);
-
- img->background_valid = 1;
- }
-
- return img->background;
-}
-
-/* Return the `background_transparent' field of IMG. If IMG doesn't
- have one yet, it is guessed heuristically. If non-zero, MASK is an
- existing XImage object to use for the heuristic. */
-
-int
-image_background_transparent (img, f, mask)
- struct image *img;
- struct frame *f;
- XImage *mask;
-{
- if (! img->background_transparent_valid)
- /* IMG doesn't have a background yet, try to guess a reasonable value. */
- {
- if (img->mask)
- {
- int free_mask = !mask;
-
- if (! mask)
- mask = XGetImage (FRAME_X_DISPLAY (f), img->mask,
- 0, 0, img->width, img->height, ~0, ZPixmap);
-
- img->background_transparent
- = !four_corners_best (mask, img->width, img->height);
-
- if (free_mask)
- XDestroyImage (mask);
- }
- else
- img->background_transparent = 0;
-
- img->background_transparent_valid = 1;
- }
-
- return img->background_transparent;
-}
-
-\f
-/***********************************************************************
- Helper functions for X image types
- ***********************************************************************/
-
-static void x_clear_image_1 P_ ((struct frame *, struct image *, int,
- int, int));
-static void x_clear_image P_ ((struct frame *f, struct image *img));
-static unsigned long x_alloc_image_color P_ ((struct frame *f,
- struct image *img,
- Lisp_Object color_name,
- unsigned long dflt));
-
-
-/* Clear X resources of image IMG on frame F. PIXMAP_P non-zero means
- free the pixmap if any. MASK_P non-zero means clear the mask
- pixmap if any. COLORS_P non-zero means free colors allocated for
- the image, if any. */
-
-static void
-x_clear_image_1 (f, img, pixmap_p, mask_p, colors_p)
- struct frame *f;
- struct image *img;
- int pixmap_p, mask_p, colors_p;
-{
- if (pixmap_p && img->pixmap)
- {
- XFreePixmap (FRAME_X_DISPLAY (f), img->pixmap);
- img->pixmap = None;
- img->background_valid = 0;
- }
-
- if (mask_p && img->mask)
- {
- XFreePixmap (FRAME_X_DISPLAY (f), img->mask);
- img->mask = None;
- img->background_transparent_valid = 0;
- }
-
- if (colors_p && img->ncolors)
- {
- x_free_colors (f, img->colors, img->ncolors);
- xfree (img->colors);
- img->colors = NULL;
- img->ncolors = 0;
- }
-}
-
-/* Free X resources of image IMG which is used on frame F. */
-
-static void
-x_clear_image (f, img)
- struct frame *f;
- struct image *img;
-{
- BLOCK_INPUT;
- x_clear_image_1 (f, img, 1, 1, 1);
- UNBLOCK_INPUT;
-}
-
-
-/* Allocate color COLOR_NAME for image IMG on frame F. If color
- cannot be allocated, use DFLT. Add a newly allocated color to
- IMG->colors, so that it can be freed again. Value is the pixel
- color. */
-
-static unsigned long
-x_alloc_image_color (f, img, color_name, dflt)
- struct frame *f;
- struct image *img;
- Lisp_Object color_name;
- unsigned long dflt;
-{
- XColor color;
- unsigned long result;
-
- xassert (STRINGP (color_name));
-
- if (x_defined_color (f, SDATA (color_name), &color, 1))
- {
- /* This isn't called frequently so we get away with simply
- reallocating the color vector to the needed size, here. */
- ++img->ncolors;
- img->colors =
- (unsigned long *) xrealloc (img->colors,
- img->ncolors * sizeof *img->colors);
- img->colors[img->ncolors - 1] = color.pixel;
- result = color.pixel;
- }
- else
- result = dflt;
-
- return result;
-}
-
-
-\f
-/***********************************************************************
- Image Cache
- ***********************************************************************/
-
-static void cache_image P_ ((struct frame *f, struct image *img));
-static void postprocess_image P_ ((struct frame *, struct image *));
-
-
-/* Return a new, initialized image cache that is allocated from the
- heap. Call free_image_cache to free an image cache. */
-
-struct image_cache *
-make_image_cache ()
-{
- struct image_cache *c = (struct image_cache *) xmalloc (sizeof *c);
- int size;
-
- bzero (c, sizeof *c);
- c->size = 50;
- c->images = (struct image **) xmalloc (c->size * sizeof *c->images);
- size = IMAGE_CACHE_BUCKETS_SIZE * sizeof *c->buckets;
- c->buckets = (struct image **) xmalloc (size);
- bzero (c->buckets, size);
- return c;
-}
-
-
-/* Free image cache of frame F. Be aware that X frames share images
- caches. */
-
-void
-free_image_cache (f)
- struct frame *f;
-{
- struct image_cache *c = FRAME_X_IMAGE_CACHE (f);
- if (c)
- {
- int i;
-
- /* Cache should not be referenced by any frame when freed. */
- xassert (c->refcount == 0);
-
- for (i = 0; i < c->used; ++i)
- free_image (f, c->images[i]);
- xfree (c->images);
- xfree (c->buckets);
- xfree (c);
- FRAME_X_IMAGE_CACHE (f) = NULL;
- }
-}
-
-
-/* Clear image cache of frame F. FORCE_P non-zero means free all
- images. FORCE_P zero means clear only images that haven't been
- displayed for some time. Should be called from time to time to
- reduce the number of loaded images. If image-eviction-seconds is
- non-nil, this frees images in the cache which weren't displayed for
- at least that many seconds. */
-
-void
-clear_image_cache (f, force_p)
- struct frame *f;
- int force_p;
-{
- struct image_cache *c = FRAME_X_IMAGE_CACHE (f);
-
- if (c && INTEGERP (Vimage_cache_eviction_delay))
- {
- EMACS_TIME t;
- unsigned long old;
- int i, nfreed;
-
- EMACS_GET_TIME (t);
- old = EMACS_SECS (t) - XFASTINT (Vimage_cache_eviction_delay);
-
- /* Block input so that we won't be interrupted by a SIGIO
- while being in an inconsistent state. */
- BLOCK_INPUT;
-
- for (i = nfreed = 0; i < c->used; ++i)
- {
- struct image *img = c->images[i];
- if (img != NULL
- && (force_p || img->timestamp < old))
- {
- free_image (f, img);
- ++nfreed;
- }
- }
-
- /* We may be clearing the image cache because, for example,
- Emacs was iconified for a longer period of time. In that
- case, current matrices may still contain references to
- images freed above. So, clear these matrices. */
- if (nfreed)
- {
- Lisp_Object tail, frame;
-
- FOR_EACH_FRAME (tail, frame)
- {
- struct frame *f = XFRAME (frame);
- if (FRAME_X_P (f)
- && FRAME_X_IMAGE_CACHE (f) == c)
- clear_current_matrices (f);
- }
-
- ++windows_or_buffers_changed;
- }
-
- UNBLOCK_INPUT;
- }
-}
-
-
-DEFUN ("clear-image-cache", Fclear_image_cache, Sclear_image_cache,
- 0, 1, 0,
- doc: /* Clear the image cache of FRAME.
-FRAME nil or omitted means use the selected frame.
-FRAME t means clear the image caches of all frames. */)
- (frame)
- Lisp_Object frame;
-{
- if (EQ (frame, Qt))
- {
- Lisp_Object tail;
-
- FOR_EACH_FRAME (tail, frame)
- if (FRAME_X_P (XFRAME (frame)))
- clear_image_cache (XFRAME (frame), 1);
- }
- else
- clear_image_cache (check_x_frame (frame), 1);
-
- return Qnil;
-}
-
-
-/* Compute masks and transform image IMG on frame F, as specified
- by the image's specification, */
-
-static void
-postprocess_image (f, img)
- struct frame *f;
- struct image *img;
-{
- /* Manipulation of the image's mask. */
- if (img->pixmap)
- {
- Lisp_Object conversion, spec;
- Lisp_Object mask;
-
- spec = img->spec;
-
- /* `:heuristic-mask t'
- `:mask heuristic'
- means build a mask heuristically.
- `:heuristic-mask (R G B)'
- `:mask (heuristic (R G B))'
- means build a mask from color (R G B) in the
- image.
- `:mask nil'
- means remove a mask, if any. */
-
- mask = image_spec_value (spec, QCheuristic_mask, NULL);
- if (!NILP (mask))
- x_build_heuristic_mask (f, img, mask);
- else
- {
- int found_p;
-
- mask = image_spec_value (spec, QCmask, &found_p);
-
- if (EQ (mask, Qheuristic))
- x_build_heuristic_mask (f, img, Qt);
- else if (CONSP (mask)
- && EQ (XCAR (mask), Qheuristic))
- {
- if (CONSP (XCDR (mask)))
- x_build_heuristic_mask (f, img, XCAR (XCDR (mask)));
- else
- x_build_heuristic_mask (f, img, XCDR (mask));
- }
- else if (NILP (mask) && found_p && img->mask)
- {
- XFreePixmap (FRAME_X_DISPLAY (f), img->mask);
- img->mask = None;
- }
- }
-
-
- /* Should we apply an image transformation algorithm? */
- conversion = image_spec_value (spec, QCconversion, NULL);
- if (EQ (conversion, Qdisabled))
- x_disable_image (f, img);
- else if (EQ (conversion, Qlaplace))
- x_laplace (f, img);
- else if (EQ (conversion, Qemboss))
- x_emboss (f, img);
- else if (CONSP (conversion)
- && EQ (XCAR (conversion), Qedge_detection))
- {
- Lisp_Object tem;
- tem = XCDR (conversion);
- if (CONSP (tem))
- x_edge_detection (f, img,
- Fplist_get (tem, QCmatrix),
- Fplist_get (tem, QCcolor_adjustment));
- }
- }
-}
-
-
-/* Return the id of image with Lisp specification SPEC on frame F.
- SPEC must be a valid Lisp image specification (see valid_image_p). */
-
-int
-lookup_image (f, spec)
- struct frame *f;
- Lisp_Object spec;
-{
- struct image_cache *c = FRAME_X_IMAGE_CACHE (f);
- struct image *img;
- int i;
- unsigned hash;
- struct gcpro gcpro1;
- EMACS_TIME now;
-
- /* F must be a window-system frame, and SPEC must be a valid image
- specification. */
- xassert (FRAME_WINDOW_P (f));
- xassert (valid_image_p (spec));
-
- GCPRO1 (spec);
-
- /* Look up SPEC in the hash table of the image cache. */
- hash = sxhash (spec, 0);
- i = hash % IMAGE_CACHE_BUCKETS_SIZE;
-
- for (img = c->buckets[i]; img; img = img->next)
- if (img->hash == hash && !NILP (Fequal (img->spec, spec)))
- break;
-
- /* If not found, create a new image and cache it. */
- if (img == NULL)
- {
- extern Lisp_Object Qpostscript;
-
- BLOCK_INPUT;
- img = make_image (spec, hash);
- cache_image (f, img);
- img->load_failed_p = img->type->load (f, img) == 0;
-
- /* If we can't load the image, and we don't have a width and
- height, use some arbitrary width and height so that we can
- draw a rectangle for it. */
- if (img->load_failed_p)
- {
- Lisp_Object value;
-
- value = image_spec_value (spec, QCwidth, NULL);
- img->width = (INTEGERP (value)
- ? XFASTINT (value) : DEFAULT_IMAGE_WIDTH);
- value = image_spec_value (spec, QCheight, NULL);
- img->height = (INTEGERP (value)
- ? XFASTINT (value) : DEFAULT_IMAGE_HEIGHT);
- }
- else
- {
- /* Handle image type independent image attributes
- `:ascent ASCENT', `:margin MARGIN', `:relief RELIEF',
- `:background COLOR'. */
- Lisp_Object ascent, margin, relief, bg;
-
- ascent = image_spec_value (spec, QCascent, NULL);
- if (INTEGERP (ascent))
- img->ascent = XFASTINT (ascent);
- else if (EQ (ascent, Qcenter))
- img->ascent = CENTERED_IMAGE_ASCENT;
-
- margin = image_spec_value (spec, QCmargin, NULL);
- if (INTEGERP (margin) && XINT (margin) >= 0)
- img->vmargin = img->hmargin = XFASTINT (margin);
- else if (CONSP (margin) && INTEGERP (XCAR (margin))
- && INTEGERP (XCDR (margin)))
- {
- if (XINT (XCAR (margin)) > 0)
- img->hmargin = XFASTINT (XCAR (margin));
- if (XINT (XCDR (margin)) > 0)
- img->vmargin = XFASTINT (XCDR (margin));
- }
-
- relief = image_spec_value (spec, QCrelief, NULL);
- if (INTEGERP (relief))
- {
- img->relief = XINT (relief);
- img->hmargin += abs (img->relief);
- img->vmargin += abs (img->relief);
- }
-
- if (! img->background_valid)
- {
- bg = image_spec_value (img->spec, QCbackground, NULL);
- if (!NILP (bg))
- {
- img->background
- = x_alloc_image_color (f, img, bg,
- FRAME_BACKGROUND_PIXEL (f));
- img->background_valid = 1;
- }
- }
-
- /* Do image transformations and compute masks, unless we
- don't have the image yet. */
- if (!EQ (*img->type->type, Qpostscript))
- postprocess_image (f, img);
- }
-
- UNBLOCK_INPUT;
- xassert (!interrupt_input_blocked);
- }
-
- /* We're using IMG, so set its timestamp to `now'. */
- EMACS_GET_TIME (now);
- img->timestamp = EMACS_SECS (now);
-
- UNGCPRO;
-
- /* Value is the image id. */
- return img->id;
-}
-
-
-/* Cache image IMG in the image cache of frame F. */
-
-static void
-cache_image (f, img)
- struct frame *f;
- struct image *img;
-{
- struct image_cache *c = FRAME_X_IMAGE_CACHE (f);
- int i;
-
- /* Find a free slot in c->images. */
- for (i = 0; i < c->used; ++i)
- if (c->images[i] == NULL)
- break;
-
- /* If no free slot found, maybe enlarge c->images. */
- if (i == c->used && c->used == c->size)
- {
- c->size *= 2;
- c->images = (struct image **) xrealloc (c->images,
- c->size * sizeof *c->images);
- }
-
- /* Add IMG to c->images, and assign IMG an id. */
- c->images[i] = img;
- img->id = i;
- if (i == c->used)
- ++c->used;
-
- /* Add IMG to the cache's hash table. */
- i = img->hash % IMAGE_CACHE_BUCKETS_SIZE;
- img->next = c->buckets[i];
- if (img->next)
- img->next->prev = img;
- img->prev = NULL;
- c->buckets[i] = img;
-}
-
-
-/* Call FN on every image in the image cache of frame F. Used to mark
- Lisp Objects in the image cache. */
-
-void
-forall_images_in_image_cache (f, fn)
- struct frame *f;
- void (*fn) P_ ((struct image *img));
-{
- if (FRAME_LIVE_P (f) && FRAME_X_P (f))
- {
- struct image_cache *c = FRAME_X_IMAGE_CACHE (f);
- if (c)
- {
- int i;
- for (i = 0; i < c->used; ++i)
- if (c->images[i])
- fn (c->images[i]);
- }
- }
-}
-
-
-\f
-/***********************************************************************
- X support code
- ***********************************************************************/
-
-static int x_create_x_image_and_pixmap P_ ((struct frame *, int, int, int,
- XImage **, Pixmap *));
-static void x_destroy_x_image P_ ((XImage *));
-static void x_put_x_image P_ ((struct frame *, XImage *, Pixmap, int, int));
-
-
-/* Create an XImage and a pixmap of size WIDTH x HEIGHT for use on
- frame F. Set *XIMG and *PIXMAP to the XImage and Pixmap created.
- Set (*XIMG)->data to a raster of WIDTH x HEIGHT pixels allocated
- via xmalloc. Print error messages via image_error if an error
- occurs. Value is non-zero if successful. */
-
-static int
-x_create_x_image_and_pixmap (f, width, height, depth, ximg, pixmap)
- struct frame *f;
- int width, height, depth;
- XImage **ximg;
- Pixmap *pixmap;
-{
- Display *display = FRAME_X_DISPLAY (f);
- Screen *screen = FRAME_X_SCREEN (f);
- Window window = FRAME_X_WINDOW (f);
-
- xassert (interrupt_input_blocked);
-
- if (depth <= 0)
- depth = DefaultDepthOfScreen (screen);
- *ximg = XCreateImage (display, DefaultVisualOfScreen (screen),
- depth, ZPixmap, 0, NULL, width, height,
- depth > 16 ? 32 : depth > 8 ? 16 : 8, 0);
- if (*ximg == NULL)
- {
- image_error ("Unable to allocate X image", Qnil, Qnil);
- return 0;
- }
-
- /* Allocate image raster. */
- (*ximg)->data = (char *) xmalloc ((*ximg)->bytes_per_line * height);
-
- /* Allocate a pixmap of the same size. */
- *pixmap = XCreatePixmap (display, window, width, height, depth);
- if (*pixmap == None)
- {
- x_destroy_x_image (*ximg);
- *ximg = NULL;
- image_error ("Unable to create X pixmap", Qnil, Qnil);
- return 0;
- }
-
- return 1;
-}
-
-
-/* Destroy XImage XIMG. Free XIMG->data. */
-
-static void
-x_destroy_x_image (ximg)
- XImage *ximg;
-{
- xassert (interrupt_input_blocked);
- if (ximg)
- {
- xfree (ximg->data);
- ximg->data = NULL;
- XDestroyImage (ximg);
- }
-}
-
-
-/* Put XImage XIMG into pixmap PIXMAP on frame F. WIDTH and HEIGHT
- are width and height of both the image and pixmap. */
-
-static void
-x_put_x_image (f, ximg, pixmap, width, height)
- struct frame *f;
- XImage *ximg;
- Pixmap pixmap;
- int width, height;
-{
- GC gc;
-
- xassert (interrupt_input_blocked);
- gc = XCreateGC (FRAME_X_DISPLAY (f), pixmap, 0, NULL);
- XPutImage (FRAME_X_DISPLAY (f), pixmap, gc, ximg, 0, 0, 0, 0, width, height);
- XFreeGC (FRAME_X_DISPLAY (f), gc);
-}
-
-
-\f
-/***********************************************************************
- File Handling
- ***********************************************************************/
-
-static Lisp_Object x_find_image_file P_ ((Lisp_Object));
-static char *slurp_file P_ ((char *, int *));
-
-
-/* Find image file FILE. Look in data-directory, then
- x-bitmap-file-path. Value is the full name of the file found, or
- nil if not found. */
-
-static Lisp_Object
-x_find_image_file (file)
- Lisp_Object file;
-{
- Lisp_Object file_found, search_path;
- struct gcpro gcpro1, gcpro2;
- int fd;
-
- file_found = Qnil;
- search_path = Fcons (Vdata_directory, Vx_bitmap_file_path);
- GCPRO2 (file_found, search_path);
-
- /* Try to find FILE in data-directory, then x-bitmap-file-path. */
- fd = openp (search_path, file, Qnil, &file_found, Qnil);
-
- if (fd == -1)
- file_found = Qnil;
- else
- close (fd);
-
- UNGCPRO;
- return file_found;
-}
-
-
-/* Read FILE into memory. Value is a pointer to a buffer allocated
- with xmalloc holding FILE's contents. Value is null if an error
- occurred. *SIZE is set to the size of the file. */
-
-static char *
-slurp_file (file, size)
- char *file;
- int *size;
-{
- FILE *fp = NULL;
- char *buf = NULL;
- struct stat st;
-
- if (stat (file, &st) == 0
- && (fp = fopen (file, "r")) != NULL
- && (buf = (char *) xmalloc (st.st_size),
- fread (buf, 1, st.st_size, fp) == st.st_size))
- {
- *size = st.st_size;
- fclose (fp);
- }
- else
- {
- if (fp)
- fclose (fp);
- if (buf)
- {
- xfree (buf);
- buf = NULL;
- }
- }
-
- return buf;
-}
-
-
-\f
-/***********************************************************************
- XBM images
- ***********************************************************************/
-
-static int xbm_scan P_ ((char **, char *, char *, int *));
-static int xbm_load P_ ((struct frame *f, struct image *img));
-static int xbm_load_image P_ ((struct frame *f, struct image *img,
- char *, char *));
-static int xbm_image_p P_ ((Lisp_Object object));
-static int xbm_read_bitmap_data P_ ((char *, char *, int *, int *,
- unsigned char **));
-static int xbm_file_p P_ ((Lisp_Object));
-
-
-/* Indices of image specification fields in xbm_format, below. */
-
-enum xbm_keyword_index
-{
- XBM_TYPE,
- XBM_FILE,
- XBM_WIDTH,
- XBM_HEIGHT,
- XBM_DATA,
- XBM_FOREGROUND,
- XBM_BACKGROUND,
- XBM_ASCENT,
- XBM_MARGIN,
- XBM_RELIEF,
- XBM_ALGORITHM,
- XBM_HEURISTIC_MASK,
- XBM_MASK,
- XBM_LAST
-};
-
-/* Vector of image_keyword structures describing the format
- of valid XBM image specifications. */
-
-static struct image_keyword xbm_format[XBM_LAST] =
-{
- {":type", IMAGE_SYMBOL_VALUE, 1},
- {":file", IMAGE_STRING_VALUE, 0},
- {":width", IMAGE_POSITIVE_INTEGER_VALUE, 0},
- {":height", IMAGE_POSITIVE_INTEGER_VALUE, 0},
- {":data", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
- {":foreground", IMAGE_STRING_OR_NIL_VALUE, 0},
- {":background", IMAGE_STRING_OR_NIL_VALUE, 0},
- {":ascent", IMAGE_ASCENT_VALUE, 0},
- {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0},
- {":relief", IMAGE_INTEGER_VALUE, 0},
- {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
- {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
- {":mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}
-};
-
-/* Structure describing the image type XBM. */
-
-static struct image_type xbm_type =
-{
- &Qxbm,
- xbm_image_p,
- xbm_load,
- x_clear_image,
- NULL
-};
-
-/* Tokens returned from xbm_scan. */
-
-enum xbm_token
-{
- XBM_TK_IDENT = 256,
- XBM_TK_NUMBER
-};
-
-
-/* Return non-zero if OBJECT is a valid XBM-type image specification.
- A valid specification is a list starting with the symbol `image'
- The rest of the list is a property list which must contain an
- entry `:type xbm..
-
- If the specification specifies a file to load, it must contain
- an entry `:file FILENAME' where FILENAME is a string.
-
- If the specification is for a bitmap loaded from memory it must
- contain `:width WIDTH', `:height HEIGHT', and `:data DATA', where
- WIDTH and HEIGHT are integers > 0. DATA may be:
-
- 1. a string large enough to hold the bitmap data, i.e. it must
- have a size >= (WIDTH + 7) / 8 * HEIGHT
-
- 2. a bool-vector of size >= WIDTH * HEIGHT
-
- 3. a vector of strings or bool-vectors, one for each line of the
- bitmap.
-
- 4. A string containing an in-memory XBM file. WIDTH and HEIGHT
- may not be specified in this case because they are defined in the
- XBM file.
-
- Both the file and data forms may contain the additional entries
- `:background COLOR' and `:foreground COLOR'. If not present,
- foreground and background of the frame on which the image is
- displayed is used. */
-
-static int
-xbm_image_p (object)
- Lisp_Object object;
-{
- struct image_keyword kw[XBM_LAST];
-
- bcopy (xbm_format, kw, sizeof kw);
- if (!parse_image_spec (object, kw, XBM_LAST, Qxbm))
- return 0;
-
- xassert (EQ (kw[XBM_TYPE].value, Qxbm));
-
- if (kw[XBM_FILE].count)
- {
- if (kw[XBM_WIDTH].count || kw[XBM_HEIGHT].count || kw[XBM_DATA].count)
- return 0;
- }
- else if (kw[XBM_DATA].count && xbm_file_p (kw[XBM_DATA].value))
- {
- /* In-memory XBM file. */
- if (kw[XBM_WIDTH].count || kw[XBM_HEIGHT].count || kw[XBM_FILE].count)
- return 0;
- }
- else
- {
- Lisp_Object data;
- int width, height;
-
- /* Entries for `:width', `:height' and `:data' must be present. */
- if (!kw[XBM_WIDTH].count
- || !kw[XBM_HEIGHT].count
- || !kw[XBM_DATA].count)
- return 0;
-
- data = kw[XBM_DATA].value;
- width = XFASTINT (kw[XBM_WIDTH].value);
- height = XFASTINT (kw[XBM_HEIGHT].value);
-
- /* Check type of data, and width and height against contents of
- data. */
- if (VECTORP (data))
- {
- int i;
-
- /* Number of elements of the vector must be >= height. */
- if (XVECTOR (data)->size < height)
- return 0;
-
- /* Each string or bool-vector in data must be large enough
- for one line of the image. */
- for (i = 0; i < height; ++i)
- {
- Lisp_Object elt = XVECTOR (data)->contents[i];
-
- if (STRINGP (elt))
- {
- if (SCHARS (elt)
- < (width + BITS_PER_CHAR - 1) / BITS_PER_CHAR)
- return 0;
- }
- else if (BOOL_VECTOR_P (elt))
- {
- if (XBOOL_VECTOR (elt)->size < width)
- return 0;
- }
- else
- return 0;
- }
- }
- else if (STRINGP (data))
- {
- if (SCHARS (data)
- < (width + BITS_PER_CHAR - 1) / BITS_PER_CHAR * height)
- return 0;
- }
- else if (BOOL_VECTOR_P (data))
- {
- if (XBOOL_VECTOR (data)->size < width * height)
- return 0;
- }
- else
- return 0;
- }
-
- return 1;
-}
-
-
-/* Scan a bitmap file. FP is the stream to read from. Value is
- either an enumerator from enum xbm_token, or a character for a
- single-character token, or 0 at end of file. If scanning an
- identifier, store the lexeme of the identifier in SVAL. If
- scanning a number, store its value in *IVAL. */
-
-static int
-xbm_scan (s, end, sval, ival)
- char **s, *end;
- char *sval;
- int *ival;
-{
- int c;
-
- loop:
-
- /* Skip white space. */
- while (*s < end && (c = *(*s)++, isspace (c)))
- ;
-
- if (*s >= end)
- c = 0;
- else if (isdigit (c))
- {
- int value = 0, digit;
-
- if (c == '0' && *s < end)
- {
- c = *(*s)++;
- if (c == 'x' || c == 'X')
- {
- while (*s < end)
- {
- c = *(*s)++;
- if (isdigit (c))
- digit = c - '0';
- else if (c >= 'a' && c <= 'f')
- digit = c - 'a' + 10;
- else if (c >= 'A' && c <= 'F')
- digit = c - 'A' + 10;
- else
- break;
- value = 16 * value + digit;
- }
- }
- else if (isdigit (c))
- {
- value = c - '0';
- while (*s < end
- && (c = *(*s)++, isdigit (c)))
- value = 8 * value + c - '0';
- }
- }
- else
- {
- value = c - '0';
- while (*s < end
- && (c = *(*s)++, isdigit (c)))
- value = 10 * value + c - '0';
- }
-
- if (*s < end)
- *s = *s - 1;
- *ival = value;
- c = XBM_TK_NUMBER;
- }
- else if (isalpha (c) || c == '_')
- {
- *sval++ = c;
- while (*s < end
- && (c = *(*s)++, (isalnum (c) || c == '_')))
- *sval++ = c;
- *sval = 0;
- if (*s < end)
- *s = *s - 1;
- c = XBM_TK_IDENT;
- }
- else if (c == '/' && **s == '*')
- {
- /* C-style comment. */
- ++*s;
- while (**s && (**s != '*' || *(*s + 1) != '/'))
- ++*s;
- if (**s)
- {
- *s += 2;
- goto loop;
- }
- }
-
- return c;
-}
-
-
-/* Replacement for XReadBitmapFileData which isn't available under old
- X versions. CONTENTS is a pointer to a buffer to parse; END is the
- buffer's end. Set *WIDTH and *HEIGHT to the width and height of
- the image. Return in *DATA the bitmap data allocated with xmalloc.
- Value is non-zero if successful. DATA null means just test if
- CONTENTS looks like an in-memory XBM file. */
-
-static int
-xbm_read_bitmap_data (contents, end, width, height, data)
- char *contents, *end;
- int *width, *height;
- unsigned char **data;
-{
- char *s = contents;
- char buffer[BUFSIZ];
- int padding_p = 0;
- int v10 = 0;
- int bytes_per_line, i, nbytes;
- unsigned char *p;
- int value;
- int LA1;
-
-#define match() \
- LA1 = xbm_scan (&s, end, buffer, &value)
-
-#define expect(TOKEN) \
- if (LA1 != (TOKEN)) \
- goto failure; \
- else \
- match ()
-
-#define expect_ident(IDENT) \
- if (LA1 == XBM_TK_IDENT && strcmp (buffer, (IDENT)) == 0) \
- match (); \
- else \
- goto failure
-
- *width = *height = -1;
- if (data)
- *data = NULL;
- LA1 = xbm_scan (&s, end, buffer, &value);
-
- /* Parse defines for width, height and hot-spots. */
- while (LA1 == '#')
- {
- match ();
- expect_ident ("define");
- expect (XBM_TK_IDENT);
-
- if (LA1 == XBM_TK_NUMBER);
- {
- char *p = strrchr (buffer, '_');
- p = p ? p + 1 : buffer;
- if (strcmp (p, "width") == 0)
- *width = value;
- else if (strcmp (p, "height") == 0)
- *height = value;
- }
- expect (XBM_TK_NUMBER);
- }
-
- if (*width < 0 || *height < 0)
- goto failure;
- else if (data == NULL)
- goto success;
-
- /* Parse bits. Must start with `static'. */
- expect_ident ("static");
- if (LA1 == XBM_TK_IDENT)
- {
- if (strcmp (buffer, "unsigned") == 0)
- {
- match ();
- expect_ident ("char");
- }
- else if (strcmp (buffer, "short") == 0)
- {
- match ();
- v10 = 1;
- if (*width % 16 && *width % 16 < 9)
- padding_p = 1;
- }
- else if (strcmp (buffer, "char") == 0)
- match ();
- else
- goto failure;
- }
- else
- goto failure;
-
- expect (XBM_TK_IDENT);
- expect ('[');
- expect (']');
- expect ('=');
- expect ('{');
-
- bytes_per_line = (*width + 7) / 8 + padding_p;
- nbytes = bytes_per_line * *height;
- p = *data = (char *) xmalloc (nbytes);
-
- if (v10)
- {
- for (i = 0; i < nbytes; i += 2)
- {
- int val = value;
- expect (XBM_TK_NUMBER);
-
- *p++ = val;
- if (!padding_p || ((i + 2) % bytes_per_line))
- *p++ = value >> 8;
-
- if (LA1 == ',' || LA1 == '}')
- match ();
- else
- goto failure;
- }
- }
- else
- {
- for (i = 0; i < nbytes; ++i)
- {
- int val = value;
- expect (XBM_TK_NUMBER);
-
- *p++ = val;
-
- if (LA1 == ',' || LA1 == '}')
- match ();
- else
- goto failure;
- }
- }
-
- success:
- return 1;
-
- failure:
-
- if (data && *data)
- {
- xfree (*data);
- *data = NULL;
- }
- return 0;
-
-#undef match
-#undef expect
-#undef expect_ident
-}
-
-
-/* Load XBM image IMG which will be displayed on frame F from buffer
- CONTENTS. END is the end of the buffer. Value is non-zero if
- successful. */
-
-static int
-xbm_load_image (f, img, contents, end)
- struct frame *f;
- struct image *img;
- char *contents, *end;
-{
- int rc;
- unsigned char *data;
- int success_p = 0;
-
- rc = xbm_read_bitmap_data (contents, end, &img->width, &img->height, &data);
- if (rc)
- {
- int depth = DefaultDepthOfScreen (FRAME_X_SCREEN (f));
- unsigned long foreground = FRAME_FOREGROUND_PIXEL (f);
- unsigned long background = FRAME_BACKGROUND_PIXEL (f);
- Lisp_Object value;
-
- xassert (img->width > 0 && img->height > 0);
-
- /* Get foreground and background colors, maybe allocate colors. */
- value = image_spec_value (img->spec, QCforeground, NULL);
- if (!NILP (value))
- foreground = x_alloc_image_color (f, img, value, foreground);
- value = image_spec_value (img->spec, QCbackground, NULL);
- if (!NILP (value))
- {
- background = x_alloc_image_color (f, img, value, background);
- img->background = background;
- img->background_valid = 1;
- }
-
- img->pixmap
- = XCreatePixmapFromBitmapData (FRAME_X_DISPLAY (f),
- FRAME_X_WINDOW (f),
- data,
- img->width, img->height,
- foreground, background,
- depth);
- xfree (data);
-
- if (img->pixmap == None)
- {
- x_clear_image (f, img);
- image_error ("Unable to create X pixmap for `%s'", img->spec, Qnil);
- }
- else
- success_p = 1;
- }
- else
- image_error ("Error loading XBM image `%s'", img->spec, Qnil);
-
- return success_p;
-}
-
-
-/* Value is non-zero if DATA looks like an in-memory XBM file. */
-
-static int
-xbm_file_p (data)
- Lisp_Object data;
-{
- int w, h;
- return (STRINGP (data)
- && xbm_read_bitmap_data (SDATA (data),
- (SDATA (data)
- + SBYTES (data)),
- &w, &h, NULL));
-}
-
-
-/* Fill image IMG which is used on frame F with pixmap data. Value is
- non-zero if successful. */
-
-static int
-xbm_load (f, img)
- struct frame *f;
- struct image *img;
-{
- int success_p = 0;
- Lisp_Object file_name;
-
- xassert (xbm_image_p (img->spec));
-
- /* If IMG->spec specifies a file name, create a non-file spec from it. */
- file_name = image_spec_value (img->spec, QCfile, NULL);
- if (STRINGP (file_name))
- {
- Lisp_Object file;
- char *contents;
- int size;
- struct gcpro gcpro1;
-
- file = x_find_image_file (file_name);
- GCPRO1 (file);
- if (!STRINGP (file))
- {
- image_error ("Cannot find image file `%s'", file_name, Qnil);
- UNGCPRO;
- return 0;
- }
-
- contents = slurp_file (SDATA (file), &size);
- if (contents == NULL)
- {
- image_error ("Error loading XBM image `%s'", img->spec, Qnil);
- UNGCPRO;
- return 0;
- }
-
- success_p = xbm_load_image (f, img, contents, contents + size);
- UNGCPRO;
- }
- else
- {
- struct image_keyword fmt[XBM_LAST];
- Lisp_Object data;
- int depth;
- unsigned long foreground = FRAME_FOREGROUND_PIXEL (f);
- unsigned long background = FRAME_BACKGROUND_PIXEL (f);
- char *bits;
- int parsed_p;
- int in_memory_file_p = 0;
-
- /* See if data looks like an in-memory XBM file. */
- data = image_spec_value (img->spec, QCdata, NULL);
- in_memory_file_p = xbm_file_p (data);
-
- /* Parse the image specification. */
- bcopy (xbm_format, fmt, sizeof fmt);
- parsed_p = parse_image_spec (img->spec, fmt, XBM_LAST, Qxbm);
- xassert (parsed_p);
-
- /* Get specified width, and height. */
- if (!in_memory_file_p)
- {
- img->width = XFASTINT (fmt[XBM_WIDTH].value);
- img->height = XFASTINT (fmt[XBM_HEIGHT].value);
- xassert (img->width > 0 && img->height > 0);
- }
-
- /* Get foreground and background colors, maybe allocate colors. */
- if (fmt[XBM_FOREGROUND].count
- && STRINGP (fmt[XBM_FOREGROUND].value))
- foreground = x_alloc_image_color (f, img, fmt[XBM_FOREGROUND].value,
- foreground);
- if (fmt[XBM_BACKGROUND].count
- && STRINGP (fmt[XBM_BACKGROUND].value))
- background = x_alloc_image_color (f, img, fmt[XBM_BACKGROUND].value,
- background);
-
- if (in_memory_file_p)
- success_p = xbm_load_image (f, img, SDATA (data),
- (SDATA (data)
- + SBYTES (data)));
- else
- {
- if (VECTORP (data))
- {
- int i;
- char *p;
- int nbytes = (img->width + BITS_PER_CHAR - 1) / BITS_PER_CHAR;
-
- p = bits = (char *) alloca (nbytes * img->height);
- for (i = 0; i < img->height; ++i, p += nbytes)
- {
- Lisp_Object line = XVECTOR (data)->contents[i];
- if (STRINGP (line))
- bcopy (SDATA (line), p, nbytes);
- else
- bcopy (XBOOL_VECTOR (line)->data, p, nbytes);
- }
- }
- else if (STRINGP (data))
- bits = SDATA (data);
- else
- bits = XBOOL_VECTOR (data)->data;
-
- /* Create the pixmap. */
- depth = DefaultDepthOfScreen (FRAME_X_SCREEN (f));
- img->pixmap
- = XCreatePixmapFromBitmapData (FRAME_X_DISPLAY (f),
- FRAME_X_WINDOW (f),
- bits,
- img->width, img->height,
- foreground, background,
- depth);
- if (img->pixmap)
- success_p = 1;
- else
- {
- image_error ("Unable to create pixmap for XBM image `%s'",
- img->spec, Qnil);
- x_clear_image (f, img);
- }
- }
- }
-
- return success_p;
-}
-
-
-\f
-/***********************************************************************
- XPM images
- ***********************************************************************/
-
-#if HAVE_XPM
-
-static int xpm_image_p P_ ((Lisp_Object object));
-static int xpm_load P_ ((struct frame *f, struct image *img));
-static int xpm_valid_color_symbols_p P_ ((Lisp_Object));
-
-#include "X11/xpm.h"
-
-/* The symbol `xpm' identifying XPM-format images. */
-
-Lisp_Object Qxpm;
-
-/* Indices of image specification fields in xpm_format, below. */
-
-enum xpm_keyword_index
-{
- XPM_TYPE,
- XPM_FILE,
- XPM_DATA,
- XPM_ASCENT,
- XPM_MARGIN,
- XPM_RELIEF,
- XPM_ALGORITHM,
- XPM_HEURISTIC_MASK,
- XPM_MASK,
- XPM_COLOR_SYMBOLS,
- XPM_BACKGROUND,
- XPM_LAST
-};
-
-/* Vector of image_keyword structures describing the format
- of valid XPM image specifications. */
-
-static struct image_keyword xpm_format[XPM_LAST] =
-{
- {":type", IMAGE_SYMBOL_VALUE, 1},
- {":file", IMAGE_STRING_VALUE, 0},
- {":data", IMAGE_STRING_VALUE, 0},
- {":ascent", IMAGE_ASCENT_VALUE, 0},
- {":margin", IMAGE_POSITIVE_INTEGER_VALUE_OR_PAIR, 0},
- {":relief", IMAGE_INTEGER_VALUE, 0},
- {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
- {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
- {":mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
- {":color-symbols", IMAGE_DONT_CHECK_VALUE_TYPE, 0},
- {":background", IMAGE_STRING_OR_NIL_VALUE, 0}
-};
-
-/* Structure describing the image type XBM. */
-
-static struct image_type xpm_type =
-{
- &Qxpm,
- xpm_image_p,
- xpm_load,
- x_clear_image,
- NULL
-};
-
-
-/* Define ALLOC_XPM_COLORS if we can use Emacs' own color allocation
- functions for allocating image colors. Our own functions handle
- color allocation failures more gracefully than the ones on the XPM
- lib. */
-
-#if defined XpmAllocColor && defined XpmFreeColors && defined XpmColorClosure
-#define ALLOC_XPM_COLORS
-#endif
-
-#ifdef ALLOC_XPM_COLORS
-
-static void xpm_init_color_cache P_ ((struct frame *, XpmAttributes *));
-static void xpm_free_color_cache P_ ((void));
-static int xpm_lookup_color P_ ((struct frame *, char *, XColor *));
-static int xpm_color_bucket P_ ((char *));
-static struct xpm_cached_color *xpm_cache_color P_ ((struct frame *, char *,
- XColor *, int));
-
-/* An entry in a hash table used to cache color definitions of named
- colors. This cache is necessary to speed up XPM image loading in
- case we do color allocations ourselves. Without it, we would need
- a call to XParseColor per pixel in the image. */
-
-struct xpm_cached_color
-{
- /* Next in collision chain. */
- struct xpm_cached_color *next;
-
- /* Color definition (RGB and pixel color). */
- XColor color;
-
- /* Color name. */
- char name[1];
-};
-
-/* The hash table used for the color cache, and its bucket vector
- size. */
-
-#define XPM_COLOR_CACHE_BUCKETS 1001
-struct xpm_cached_color **xpm_color_cache;
-
-/* Initialize the color cache. */
-
-static void
-xpm_init_color_cache (f, attrs)
- struct frame *f;
- XpmAttributes *attrs;
-{
- size_t nbytes = XPM_COLOR_CACHE_BUCKETS * sizeof *xpm_color_cache;
- xpm_color_cache = (struct xpm_cached_color **) xmalloc (nbytes);
- memset (xpm_color_cache, 0, nbytes);
- init_color_table ();
-
- if (attrs->valuemask & XpmColorSymbols)
- {
- int i;
- XColor color;
-
- for (i = 0; i < attrs->numsymbols; ++i)
- if (XParseColor (FRAME_X_DISPLAY (f), FRAME_X_COLORMAP (f),
- attrs->colorsymbols[i].value, &color))
- {
- color.pixel = lookup_rgb_color (f, color.red, color.green,
- color.blue);
- xpm_cache_color (f, attrs->colorsymbols[i].name, &color, -1);
- }
- }
-}
-
-
-/* Free the color cache. */
-
-static void
-xpm_free_color_cache ()
-{
- struct xpm_cached_color *p, *next;
- int i;
-
- for (i = 0; i < XPM_COLOR_CACHE_BUCKETS; ++i)
- for (p = xpm_color_cache[i]; p; p = next)
- {
- next = p->next;
- xfree (p);
- }
-
- xfree (xpm_color_cache);
- xpm_color_cache = NULL;
- free_color_table ();
-}
-
-
-/* Return the bucket index for color named COLOR_NAME in the color
- cache. */
-
-static int
-xpm_color_bucket (color_name)
- char *color_name;
-{
- unsigned h = 0;
- char *s;
-
- for (s = color_name; *s; ++s)
- h = (h << 2) ^ *s;
- return h %= XPM_COLOR_CACHE_BUCKETS;
-}
-
-
-/* On frame F, cache values COLOR for color with name COLOR_NAME.
- BUCKET, if >= 0, is a precomputed bucket index. Value is the cache
- entry added. */
-
-static struct xpm_cached_color *
-xpm_cache_color (f, color_name, color, bucket)
- struct frame *f;
- char *color_name;
- XColor *color;
- int bucket;
-{
- size_t nbytes;
- struct xpm_cached_color *p;
-
- if (bucket < 0)
- bucket = xpm_color_bucket (color_name);
-
- nbytes = sizeof *p + strlen (color_name);
- p = (struct xpm_cached_color *) xmalloc (nbytes);
- strcpy (p->name, color_name);
- p->color = *color;
- p->next = xpm_color_cache[bucket];
- xpm_color_cache[bucket] = p;
- return p;
-}
-
-
-/* Look up color COLOR_NAME for frame F in the color cache. If found,
- return the cached definition in *COLOR. Otherwise, make a new
- entry in the cache and allocate the color. Value is zero if color
- allocation failed. */
-
-static int
-xpm_lookup_color (f, color_name, color)
- struct frame *f;
- char *color_name;
- XColor *color;
-{
- struct xpm_cached_color *p;
- int h = xpm_color_bucket (color_name);
-
- for (p = xpm_color_cache[h]; p; p = p->next)
- if (strcmp (p->name, color_name) == 0)
- break;
-
- if (p != NULL)
- *color = p->color;
- else if (XParseColor (FRAME_X_DISPLAY (f), FRAME_X_COLORMAP (f),
- color_name, color))
- {
- color->pixel = lookup_rgb_color (f, color->red, color->green,
- color->blue);
- p = xpm_cache_color (f, color_name, color, h);
- }
-
- return p != NULL;
-}
-
-
-/* Callback for allocating color COLOR_NAME. Called from the XPM lib.
- CLOSURE is a pointer to the frame on which we allocate the
- color. Return in *COLOR the allocated color. Value is non-zero
- if successful. */
-
-static int
-xpm_alloc_color (dpy, cmap, color_name, color, closure)
- Display *dpy;
- Colormap cmap;
- char *color_name;
- XColor *color;
- void *closure;
-{
- return xpm_lookup_color ((struct frame *) closure, color_name, color);
-}
-
-
-/* Callback for freeing NPIXELS colors contained in PIXELS. CLOSURE
- is a pointer to the frame on which we allocate the color. Value is
- non-zero if successful. */
-
-static int
-xpm_free_colors (dpy, cmap, pixels, npixels, closure)
- Display *dpy;
- Colormap cmap;
- Pixel *pixels;
- int npixels;
- void *closure;
-{
- return 1;
-}
-
-#endif /* ALLOC_XPM_COLORS */
-
-
-/* Value is non-zero if COLOR_SYMBOLS is a valid color symbols list
- for XPM images. Such a list must consist of conses whose car and
- cdr are strings. */
-
-static int
-xpm_valid_color_symbols_p (color_symbols)
- Lisp_Object color_symbols;
-{
- while (CONSP (color_symbols))
- {
- Lisp_Object sym = XCAR (color_symbols);
- if (!CONSP (sym)
- || !STRINGP (XCAR (sym))
- || !STRINGP (XCDR (sym)))
- break;
- color_symbols = XCDR (color_symbols);
- }
-
- return NILP (color_symbols);
-}
-
-
-/* Value is non-zero if OBJECT is a valid XPM image specification. */
-
-static int
-xpm_image_p (object)
- Lisp_Object object;
-{
- struct image_keyword fmt[XPM_LAST];
- bcopy (xpm_format, fmt, sizeof fmt);
- return (parse_image_spec (object, fmt, XPM_LAST, Qxpm)
- /* Either `:file' or `:data' must be present. */
- && fmt[XPM_FILE].count + fmt[XPM_DATA].count == 1
- /* Either no `:color-symbols' or it's a list of conses
- whose car and cdr are strings. */
- && (fmt[XPM_COLOR_SYMBOLS].count == 0
- || xpm_valid_color_symbols_p (fmt[XPM_COLOR_SYMBOLS].value)));
-}
-
-
-/* Load image IMG which will be displayed on frame F. Value is
- non-zero if successful. */
-
-static int
-xpm_load (f, img)
- struct frame *f;
- struct image *img;
-{
- int rc;
- XpmAttributes attrs;
- Lisp_Object specified_file, color_symbols;
-
- /* Configure the XPM lib. Use the visual of frame F. Allocate
- close colors. Return colors allocated. */
- bzero (&attrs, sizeof attrs);
- attrs.visual = FRAME_X_VISUAL (f);
- attrs.colormap = FRAME_X_COLORMAP (f);
- attrs.valuemask |= XpmVisual;
- attrs.valuemask |= XpmColormap;
-
-#ifdef ALLOC_XPM_COLORS
- /* Allocate colors with our own functions which handle
- failing color allocation more gracefully. */
- attrs.color_closure = f;
- attrs.alloc_color = xpm_alloc_color;
- attrs.free_colors = xpm_free_colors;
- attrs.valuemask |= XpmAllocColor | XpmFreeColors | XpmColorClosure;
-#else /* not ALLOC_XPM_COLORS */
- /* Let the XPM lib allocate colors. */
- attrs.valuemask |= XpmReturnAllocPixels;
-#ifdef XpmAllocCloseColors
- attrs.alloc_close_colors = 1;
- attrs.valuemask |= XpmAllocCloseColors;
-#else /* not XpmAllocCloseColors */
- attrs.closeness = 600;
- attrs.valuemask |= XpmCloseness;
-#endif /* not XpmAllocCloseColors */
-#endif /* ALLOC_XPM_COLORS */
-
- /* If image specification contains symbolic color definitions, add
- these to `attrs'. */
- color_symbols = image_spec_value (img->spec, QCcolor_symbols, NULL);
- if (CONSP (color_symbols))
- {
- Lisp_Object tail;
- XpmColorSymbol *xpm_syms;
- int i, size;
-
- attrs.valuemask |= XpmColorSymbols;
-
- /* Count number of symbols. */
- attrs.numsymbols = 0;
- for (tail = color_symbols; CONSP (tail); tail = XCDR (tail))
- ++attrs.numsymbols;
-
- /* Allocate an XpmColorSymbol array. */
- size = attrs.numsymbols * sizeof *xpm_syms;
- xpm_syms = (XpmColorSymbol *) alloca (size);
- bzero (xpm_syms, size);
- attrs.colorsymbols = xpm_syms;
-
- /* Fill the color symbol array. */
- for (tail = color_symbols, i = 0;
- CONSP (tail);
- ++i, tail = XCDR (tail))
- {
- Lisp_Object name = XCAR (XCAR (tail));
- Lisp_Object color = XCDR (XCAR (tail));
- xpm_syms[i].name = (char *) alloca (SCHARS (name) + 1);
- strcpy (xpm_syms[i].name, SDATA (name));
- xpm_syms[i].value = (char *) alloca (SCHARS (color) + 1);
- strcpy (xpm_syms[i].value, SDATA (color));
- }
- }
-
- /* Create a pixmap for the image, either from a file, or from a
- string buffer containing data in the same format as an XPM file. */
-#ifdef ALLOC_XPM_COLORS
- xpm_init_color_cache (f, &attrs);
-#endif
-
- specified_file = image_spec_value (img->spec, QCfile, NULL);
- if (STRINGP (specified_file))
- {
- Lisp_Object file = x_find_image_file (specified_file);
- if (!STRINGP (file))
- {
- image_error ("Cannot find image file `%s'", specified_file, Qnil);
- return 0;
- }
-
- rc = XpmReadFileToPixmap (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f),
- SDATA (file), &img->pixmap, &img->mask,
- &attrs);
- }
- else
- {
- Lisp_Object buffer = image_spec_value (img->spec, QCdata, NULL);
- rc = XpmCreatePixmapFromBuffer (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f),
- SDATA (buffer),
- &img->pixmap, &img->mask,
- &attrs);
- }
-
- if (rc == XpmSuccess)
- {
-#ifdef ALLOC_XPM_COLORS
- img->colors = colors_in_color_table (&img->ncolors);
-#else /* not ALLOC_XPM_COLORS */
- int i;
-
- img->ncolors = attrs.nalloc_pixels;
- img->colors = (unsigned long *) xmalloc (img->ncolors
- * sizeof *img->colors);
- for (i = 0; i < attrs.nalloc_pixels; ++i)
- {
- img->colors[i] = attrs.alloc_pixels[i];
-#ifdef DEBUG_X_COLORS
- register_color (img->colors[i]);
-#endif
- }
-#endif /* not ALLOC_XPM_COLORS */
-
- img->width = attrs.width;
- img->height = attrs.height;
- xassert (img->width > 0 && img->height > 0);
-
- /* The call to XpmFreeAttributes below frees attrs.alloc_pixels. */
- XpmFreeAttributes (&attrs);
- }
- else
- {
- switch (rc)
- {
- case XpmOpenFailed:
- image_error ("Error opening XPM file (%s)", img->spec, Qnil);
- break;
-
- case XpmFileInvalid:
- image_error ("Invalid XPM file (%s)", img->spec, Qnil);
- break;
-
- case XpmNoMemory:
- image_error ("Out of memory (%s)", img->spec, Qnil);
- break;
-
- case XpmColorFailed:
- image_error ("Color allocation error (%s)", img->spec, Qnil);
- break;
-
- default:
- image_error ("Unknown error (%s)", img->spec, Qnil);
- break;
- }
- }
-
-#ifdef ALLOC_XPM_COLORS
- xpm_free_color_cache ();
-#endif
- return rc == XpmSuccess;
-}
-
-#endif /* HAVE_XPM != 0 */
-
-\f
-/***********************************************************************
- Color table
- ***********************************************************************/
-
-/* An entry in the color table mapping an RGB color to a pixel color. */
-
-struct ct_color
-{
- int r, g, b;
- unsigned long pixel;
-
- /* Next in color table collision list. */
- struct ct_color *next;
-};
-
-/* The bucket vector size to use. Must be prime. */
-
-#define CT_SIZE 101
-
-/* Value is a hash of the RGB color given by R, G, and B. */
-
-#define CT_HASH_RGB(R, G, B) (((R) << 16) ^ ((G) << 8) ^ (B))
-
-/* The color hash table. */
-
-struct ct_color **ct_table;
-
-/* Number of entries in the color table. */
-
-int ct_colors_allocated;
-
-/* Initialize the color table. */
-
-static void
-init_color_table ()
-{
- int size = CT_SIZE * sizeof (*ct_table);
- ct_table = (struct ct_color **) xmalloc (size);
- bzero (ct_table, size);
- ct_colors_allocated = 0;
-}
-
-
-/* Free memory associated with the color table. */
-
-static void
-free_color_table ()
-{
- int i;
- struct ct_color *p, *next;
-
- for (i = 0; i < CT_SIZE; ++i)
- for (p = ct_table[i]; p; p = next)
- {
- next = p->next;
- xfree (p);
- }
-
- xfree (ct_table);
- ct_table = NULL;
-}
-
-
-/* Value is a pixel color for RGB color R, G, B on frame F. If an
- entry for that color already is in the color table, return the
- pixel color of that entry. Otherwise, allocate a new color for R,
- G, B, and make an entry in the color table. */
-
-static unsigned long
-lookup_rgb_color (f, r, g, b)
- struct frame *f;
- int r, g, b;
-{
- unsigned hash = CT_HASH_RGB (r, g, b);
- int i = hash % CT_SIZE;
- struct ct_color *p;
-
- for (p = ct_table[i]; p; p = p->next)
- if (p->r == r && p->g == g && p->b == b)
- break;
-
- if (p == NULL)
- {
- XColor color;
- Colormap cmap;
- int rc;
-
- color.red = r;
- color.green = g;
- color.blue = b;
-
- cmap = FRAME_X_COLORMAP (f);
- rc = x_alloc_nearest_color (f, cmap, &color);
-
- if (rc)
- {
- ++ct_colors_allocated;
-
- p = (struct ct_color *) xmalloc (sizeof *p);
- p->r = r;
- p->g = g;
- p->b = b;
- p->pixel = color.pixel;
- p->next = ct_table[i];
- ct_table[i] = p;
- }
- else
- return FRAME_FOREGROUND_PIXEL (f);
- }
-
- return p->pixel;
-}
-
-
-/* Look up pixel color PIXEL which is used on frame F in the color
- table. If not already present, allocate it. Value is PIXEL. */
-
-static unsigned long
-lookup_pixel_color (f, pixel)
- struct frame *f;
- unsigned long pixel;
-{
- int i = pixel % CT_SIZE;
- struct ct_color *p;
-
- for (p = ct_table[i]; p; p = p->next)
- if (p->pixel == pixel)
- break;
-
- if (p == NULL)
- {
- XColor color;
- Colormap cmap;
- int rc;
-
- cmap = FRAME_X_COLORMAP (f);
- color.pixel = pixel;
- x_query_color (f, &color);
- rc = x_alloc_nearest_color (f, cmap, &color);
-
- if (rc)
- {
- ++ct_colors_allocated;
-
- p = (struct ct_color *) xmalloc (sizeof *p);
- p->r = color.red;
- p->g = color.green;
- p->b = color.blue;
- p->pixel = pixel;
- p->next = ct_table[i];
- ct_table[i] = p;
- }
- else
- return FRAME_FOREGROUND_PIXEL (f);
- }