--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/gui-x.c	Mon Aug 13 11:28:15 2007 +0200
@@ -0,0 +1,651 @@
+/* General GUI code -- X-specific. (menubars, scrollbars, toolbars, dialogs)
+   Copyright (C) 1995 Board of Trustees, University of Illinois.
+   Copyright (C) 1995, 1996 Ben Wing.
+   Copyright (C) 1995 Sun Microsystems, Inc.
+   Copyright (C) 1998 Free Software Foundation, Inc.
+
+This file is part of XEmacs.
+
+XEmacs is free software; you can redistribute it and/or modify it
+under the terms of the GNU General Public License as published by the
+Free Software Foundation; either version 2, or (at your option) any
+later version.
+
+XEmacs is distributed in the hope that it will be useful, but WITHOUT
+ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with XEmacs; see the file COPYING.  If not, write to
+the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.  */
+
+/* Synched up with: Not in FSF. */
+
+#include <config.h>
+#include "lisp.h"
+
+#include "console-x.h"
+#ifdef LWLIB_USES_MOTIF
+#include <Xm/Xm.h> /* for XmVersion */
+#endif
+#include "gui-x.h"
+#include "buffer.h"
+#include "device.h"
+#include "frame.h"
+#include "gui.h"
+#include "redisplay.h"
+#include "opaque.h"
+
+Lisp_Object Qmenu_no_selection_hook;
+
+/* we need a unique id for each popup menu, dialog box, and scrollbar */
+static unsigned int lwlib_id_tick;
+
+LWLIB_ID
+new_lwlib_id (void)
+{
+  return ++lwlib_id_tick;
+}
+
+widget_value *
+xmalloc_widget_value (void)
+{
+  widget_value *tmp = malloc_widget_value ();
+  if (!tmp) memory_full ();
+  return tmp;
+}
+
+
+static int
+mark_widget_value_mapper (widget_value *val, void *closure)
+{
+  Lisp_Object markee;
+  if (val->call_data)
+    {
+      VOID_TO_LISP (markee, val->call_data);
+      mark_object (markee);
+    }
+
+  if (val->accel)
+    {
+      VOID_TO_LISP (markee, val->accel);
+      mark_object (markee);
+    }
+  return 0;
+}
+
+static Lisp_Object
+mark_popup_data (Lisp_Object obj)
+{
+  struct popup_data *data = (struct popup_data *) XPOPUP_DATA (obj);
+
+  /* Now mark the callbacks and such that are hidden in the lwlib
+     call-data */
+
+  if (data->id)
+    lw_map_widget_values (data->id, mark_widget_value_mapper, 0);
+
+  return data->last_menubar_buffer;
+}
+
+DEFINE_LRECORD_IMPLEMENTATION ("popup-data", popup_data,
+                               mark_popup_data, internal_object_printer,
+			       0, 0, 0, 0, struct popup_data);
+
+/* This is like FRAME_MENUBAR_DATA (f), but contains an alist of
+   (id . popup-data) for GCPRO'ing the callbacks of the popup menus
+   and dialog boxes. */
+static Lisp_Object Vpopup_callbacks;
+
+void
+gcpro_popup_callbacks (LWLIB_ID id)
+{
+  struct popup_data *pdata;
+  Lisp_Object lid = make_int (id);
+  Lisp_Object lpdata;
+
+  assert (NILP (assq_no_quit (lid, Vpopup_callbacks)));
+  pdata = alloc_lcrecord_type (struct popup_data, &lrecord_popup_data);
+  pdata->id = id;
+  pdata->last_menubar_buffer = Qnil;
+  pdata->menubar_contents_up_to_date = 0;
+  XSETPOPUP_DATA (lpdata, pdata);
+  Vpopup_callbacks = Fcons (Fcons (lid, lpdata), Vpopup_callbacks);
+}
+
+void
+ungcpro_popup_callbacks (LWLIB_ID id)
+{
+  Lisp_Object lid = make_int (id);
+  Lisp_Object this = assq_no_quit (lid, Vpopup_callbacks);
+  assert (!NILP (this));
+  Vpopup_callbacks = delq_no_quit (this, Vpopup_callbacks);
+}
+
+int
+popup_handled_p (LWLIB_ID id)
+{
+  return NILP (assq_no_quit (make_int (id), Vpopup_callbacks));
+}
+
+/* menu_item_descriptor_to_widget_value() et al. mallocs a
+   widget_value, but then may signal lisp errors.  If an error does
+   not occur, the opaque ptr we have here has had its pointer set to 0
+   to tell us not to do anything.  Otherwise we free the widget value.
+   (This has nothing to do with GC, it's just about not dropping
+   pointers to malloc'd data when errors happen.) */
+
+Lisp_Object
+widget_value_unwind (Lisp_Object closure)
+{
+  widget_value *wv = (widget_value *) get_opaque_ptr (closure);
+  free_opaque_ptr (closure);
+  if (wv)
+    free_widget_value (wv);
+  return Qnil;
+}
+
+#if 0
+static void
+print_widget_value (widget_value *wv, int depth)
+{
+  /* !!#### This function has not been Mule-ized */
+  char d [200];
+  int i;
+  for (i = 0; i < depth; i++) d[i] = ' ';
+  d[depth]=0;
+  /* #### - print type field */
+  printf ("%sname:    %s\n", d, (wv->name ? wv->name : "(null)"));
+  if (wv->value) printf ("%svalue:   %s\n", d, wv->value);
+  if (wv->key)   printf ("%skey:     %s\n", d, wv->key);
+  printf ("%senabled: %d\n", d, wv->enabled);
+  if (wv->contents)
+    {
+      printf ("\n%scontents: \n", d);
+      print_widget_value (wv->contents, depth + 5);
+    }
+  if (wv->next)
+    {
+      printf ("\n");
+      print_widget_value (wv->next, depth);
+    }
+}
+#endif
+
+/* This recursively calls free_widget_value() on the tree of widgets.
+   It must free all data that was malloc'ed for these widget_values.
+
+   It used to be that emacs only allocated new storage for the `key' slot.
+   All other slots are pointers into the data of Lisp_Strings, and must be
+   left alone.  */
+void
+free_popup_widget_value_tree (widget_value *wv)
+{
+  if (! wv) return;
+  if (wv->key) xfree (wv->key);
+  if (wv->value) xfree (wv->value);
+
+  wv->name = wv->value = wv->key = (char *) 0xDEADBEEF;
+
+  if (wv->contents && (wv->contents != (widget_value*)1))
+    {
+      free_popup_widget_value_tree (wv->contents);
+      wv->contents = (widget_value *) 0xDEADBEEF;
+    }
+  if (wv->next)
+    {
+      free_popup_widget_value_tree (wv->next);
+      wv->next = (widget_value *) 0xDEADBEEF;
+    }
+  free_widget_value (wv);
+}
+
+/* The following is actually called from somewhere within XtDispatchEvent(),
+   called from XtAppProcessEvent() in event-Xt.c */
+
+void
+popup_selection_callback (Widget widget, LWLIB_ID ignored_id,
+			  XtPointer client_data)
+{
+  Lisp_Object fn, arg;
+  Lisp_Object data;
+  Lisp_Object frame;
+  struct device *d = get_device_from_display (XtDisplay (widget));
+  struct frame *f = x_any_widget_or_parent_to_frame (d, widget);
+
+  /* set in lwlib to the time stamp associated with the most recent menu
+     operation */
+  extern Time x_focus_timestamp_really_sucks_fix_me_better;
+
+  if (!f)
+    return;
+  if (((EMACS_INT) client_data) == 0)
+    return;
+  VOID_TO_LISP (data, client_data);
+  XSETFRAME (frame, f);
+
+#if 0
+  /* #### What the hell?  I can't understand why this call is here,
+     and doing it is really courting disaster in the new event
+     model, since popup_selection_callback is called from
+     within next_event_internal() and Faccept_process_output()
+     itself calls next_event_internal().  --Ben */
+
+  /* Flush the X and process input */
+  Faccept_process_output (Qnil, Qnil, Qnil);
+#endif
+
+  if (((EMACS_INT) client_data) == -1)
+    {
+      fn = Qrun_hooks;
+      arg = Qmenu_no_selection_hook;
+    }
+  else
+    {
+      MARK_SUBWINDOWS_STATE_CHANGED;
+      get_gui_callback (data, &fn, &arg);
+    }
+
+  /* This is the timestamp used for asserting focus so we need to get an
+     up-to-date value event if no events has been dispatched to emacs
+     */
+#if defined(HAVE_MENUBARS)
+  DEVICE_X_MOUSE_TIMESTAMP (d) = x_focus_timestamp_really_sucks_fix_me_better;
+#else
+  DEVICE_X_MOUSE_TIMESTAMP (d) = DEVICE_X_GLOBAL_MOUSE_TIMESTAMP (d);
+#endif
+  signal_special_Xt_user_event (frame, fn, arg);
+}
+
+#if 1
+  /* Eval the activep slot of the menu item */
+# define wv_set_evalable_slot(slot,form) do {	\
+  Lisp_Object wses_form = (form);		\
+  (slot) = (NILP (wses_form) ? 0 :		\
+	    EQ (wses_form, Qt) ? 1 :		\
+	    !NILP (Feval (wses_form)));		\
+} while (0)
+#else
+  /* Treat the activep slot of the menu item as a boolean */
+# define wv_set_evalable_slot(slot,form)	\
+      ((void) (slot = (!NILP (form))))
+#endif
+
+char *
+menu_separator_style (CONST char *s)
+{
+  CONST char *p;
+  char first;
+
+  if (!s || s[0] == '\0')
+    return NULL;
+  first = s[0];
+  if (first != '-' && first != '=')
+    return NULL;
+  for (p = s; *p == first; p++)
+    DO_NOTHING;
+
+  /* #### - cannot currently specify a separator tag "--!tag" and a
+     separator style "--:style" at the same time. */
+  /* #### - Also, the motif menubar code doesn't deal with the
+     double etched style yet, so it's not good to get into the habit of
+     using "===" in menubars to get double-etched lines */
+  if (*p == '!' || *p == '\0')
+    return ((first == '-')
+	    ? NULL			/* single etched is the default */
+	    : xstrdup ("shadowDoubleEtchedIn"));
+  else if (*p == ':')
+    return xstrdup (p+1);
+
+  return NULL;
+}
+
+
+/* This does the dirty work.  gc_currently_forbidden is 1 when this is called.
+ */
+int
+button_item_to_widget_value (Lisp_Object gui_item, widget_value *wv,
+			     int allow_text_field_p, int no_keys_p)
+{
+  /* !!#### This function has not been Mule-ized */
+  /* This function cannot GC because gc_currently_forbidden is set when
+     it's called */
+  struct Lisp_Gui_Item* pgui = 0;
+
+  /* degenerate case */
+  if (STRINGP (gui_item))
+    {
+      wv->type = TEXT_TYPE;
+      wv->name = (char *) XSTRING_DATA (gui_item);
+      wv->name = xstrdup (wv->name);
+      return 1;
+    }
+  else if (!GUI_ITEMP (gui_item))
+    signal_simple_error("need a string or a gui_item here", gui_item);
+
+  pgui = XGUI_ITEM (gui_item);
+
+  if (!NILP (pgui->filter))
+    signal_simple_error(":filter keyword not permitted on leaf nodes", gui_item);
+
+#ifdef HAVE_MENUBARS
+  if (!gui_item_included_p (gui_item, Vmenubar_configuration))
+    {
+      /* the include specification says to ignore this item. */
+      return 0;
+    }
+#endif /* HAVE_MENUBARS */
+
+  CHECK_STRING (pgui->name);
+  wv->name = (char *) XSTRING_DATA (pgui->name);
+  wv->name = xstrdup (wv->name);
+  wv->accel = LISP_TO_VOID (gui_item_accelerator (gui_item));
+
+  if (!NILP (pgui->suffix))
+    {
+      CONST char *const_bogosity;
+      Lisp_Object suffix2;
+
+      /* Shortcut to avoid evaluating suffix each time */
+      if (STRINGP (pgui->suffix))
+	suffix2 = pgui->suffix;
+      else
+	{
+	  suffix2 = Feval (pgui->suffix);
+	  CHECK_STRING (suffix2);
+	}
+
+      GET_C_STRING_FILENAME_DATA_ALLOCA (suffix2, const_bogosity);
+      wv->value = (char *) const_bogosity;
+      wv->value = xstrdup (wv->value);
+    }
+
+  wv_set_evalable_slot (wv->enabled, pgui->active);
+  wv_set_evalable_slot (wv->selected, pgui->selected);
+
+  if (!NILP (pgui->callback))
+    wv->call_data = LISP_TO_VOID (pgui->callback);
+
+  if (no_keys_p
+#ifdef HAVE_MENUBARS
+      || !menubar_show_keybindings
+#endif
+      )
+    wv->key = 0;
+  else if (!NILP (pgui->keys))	/* Use this string to generate key bindings */
+    {
+      CHECK_STRING (pgui->keys);
+      pgui->keys = Fsubstitute_command_keys (pgui->keys);
+      if (XSTRING_LENGTH (pgui->keys) > 0)
+	wv->key = xstrdup ((char *) XSTRING_DATA (pgui->keys));
+      else
+	wv->key = 0;
+    }
+  else if (SYMBOLP (pgui->callback))	/* Show the binding of this command. */
+    {
+      char buf [1024];
+      /* #### Warning, dependency here on current_buffer and point */
+      where_is_to_char (pgui->callback, buf);
+      if (buf [0])
+	wv->key = xstrdup (buf);
+      else
+	wv->key = 0;
+    }
+
+  CHECK_SYMBOL (pgui->style);
+  if (NILP (pgui->style))
+    {
+      /* If the callback is nil, treat this item like unselectable text.
+	 This way, dashes will show up as a separator. */
+      if (!wv->enabled)
+	wv->type = BUTTON_TYPE;
+      if (separator_string_p (wv->name))
+	{
+	  wv->type = SEPARATOR_TYPE;
+	  wv->value = menu_separator_style (wv->name);
+	}
+      else
+	{
+#if 0
+	  /* #### - this is generally desirable for menubars, but it breaks
+	     a package that uses dialog boxes and next_command_event magic
+	     to use the callback slot in dialog buttons for data instead of
+	     a real callback.
+
+	     Code is data, right?  The beauty of LISP abuse.   --Stig */
+	  if (NILP (callback))
+	    wv->type = TEXT_TYPE;
+	  else
+#endif
+	    wv->type = BUTTON_TYPE;
+	}
+    }
+  else if (EQ (pgui->style, Qbutton))
+    wv->type = BUTTON_TYPE;
+  else if (EQ (pgui->style, Qtoggle))
+    wv->type = TOGGLE_TYPE;
+  else if (EQ (pgui->style, Qradio))
+    wv->type = RADIO_TYPE;
+  else if (EQ (pgui->style, Qtext))
+    {
+      wv->type = TEXT_TYPE;
+#if 0
+      wv->value = wv->name;
+      wv->name = "value";
+#endif
+    }
+  else
+    signal_simple_error_2 ("Unknown style", pgui->style, gui_item);
+
+  if (!allow_text_field_p && (wv->type == TEXT_TYPE))
+    signal_simple_error ("Text field not allowed in this context", gui_item);
+
+  if (!NILP (pgui->selected) && EQ (pgui->style, Qtext))
+    signal_simple_error (
+			 ":selected only makes sense with :style toggle, radio or button",
+			 gui_item);
+  return 1;
+}
+
+/* parse tree's of gui items into widget_value hierarchies */
+static void gui_item_children_to_widget_values (Lisp_Object items, widget_value* parent);
+
+static widget_value *
+gui_items_to_widget_values_1 (Lisp_Object items, widget_value* parent,
+			      widget_value* prev)
+{
+  widget_value* wv = 0;
+
+  assert ((parent || prev) && !(parent && prev));
+  /* now walk the tree creating widget_values as appropriate */
+  if (!CONSP (items))
+    {
+      wv = xmalloc_widget_value();
+      if (parent)
+	parent->contents = wv;
+      else 
+	prev->next = wv;
+      if (!button_item_to_widget_value (items, wv, 0, 1))
+	{
+	  free_widget_value (wv);
+	  if (parent)
+	    parent->contents = 0;
+	  else 
+	    prev->next = 0;
+	}
+      else 
+	{
+	  wv->value = xstrdup (wv->name);	/* what a mess... */
+	}
+    }
+  else
+    {
+      /* first one is the parent */
+      if (CONSP (XCAR (items)))
+	signal_simple_error ("parent item must not be a list", XCAR (items));
+
+      if (parent)
+	wv = gui_items_to_widget_values_1 (XCAR (items), parent, 0);
+      else
+	wv = gui_items_to_widget_values_1 (XCAR (items), 0, prev);
+      /* the rest are the children */
+      gui_item_children_to_widget_values (XCDR (items), wv);
+    }
+  return wv;
+}
+
+static void
+gui_item_children_to_widget_values (Lisp_Object items, widget_value* parent)
+{
+  widget_value* wv = 0, *prev = 0;
+  Lisp_Object rest;
+  CHECK_CONS (items);
+
+  /* first one is master */
+  prev = gui_items_to_widget_values_1 (XCAR (items), parent, 0);
+  /* the rest are the children */
+  LIST_LOOP (rest, XCDR (items))
+    {
+      Lisp_Object tab = XCAR (rest);
+      wv = gui_items_to_widget_values_1 (tab, 0, prev);
+      prev = wv;
+    }
+}
+
+widget_value *
+gui_items_to_widget_values (Lisp_Object items)
+{
+  /* !!#### This function has not been Mule-ized */
+  /* This function can GC */
+  widget_value *control = 0, *tmp = 0;
+  int count = specpdl_depth ();
+  Lisp_Object wv_closure;
+
+  if (NILP (items))
+    signal_simple_error ("must have some items", items);
+
+  /* Inhibit GC during this conversion.  The reasons for this are
+     the same as in menu_item_descriptor_to_widget_value(); see
+     the large comment above that function. */
+  record_unwind_protect (restore_gc_inhibit,
+			 make_int (gc_currently_forbidden));
+  gc_currently_forbidden = 1;
+
+  /* Also make sure that we free the partially-created widget_value
+     tree on Lisp error. */
+  control = xmalloc_widget_value();
+  wv_closure = make_opaque_ptr (control);
+  record_unwind_protect (widget_value_unwind, wv_closure);
+
+  gui_items_to_widget_values_1 (items, control, 0);
+
+  /* mess about getting the data we really want */
+  tmp = control;
+  control = control->contents;
+  tmp->next = 0;
+  tmp->contents = 0;
+  free_widget_value (tmp);
+
+  /* No more need to free the half-filled-in structures. */
+  set_opaque_ptr (wv_closure, 0);
+  unbind_to (count, Qnil);
+
+  return control;
+}
+
+/* This is a kludge to make sure emacs can only link against a version of
+   lwlib that was compiled in the right way.  Emacs references symbols which
+   correspond to the way it thinks lwlib was compiled, and if lwlib wasn't
+   compiled in that way, then somewhat meaningful link errors will result.
+   The alternatives to this range from obscure link errors, to obscure
+   runtime errors that look a lot like bugs.
+ */
+
+static void
+sanity_check_lwlib (void)
+{
+#define MACROLET(v) { extern int v; v = 1; }
+
+#if (XlibSpecificationRelease == 4)
+  MACROLET (lwlib_uses_x11r4);
+#elif (XlibSpecificationRelease == 5)
+  MACROLET (lwlib_uses_x11r5);
+#elif (XlibSpecificationRelease == 6)
+  MACROLET (lwlib_uses_x11r6);
+#else
+  MACROLET (lwlib_uses_unknown_x11);
+#endif
+#ifdef LWLIB_USES_MOTIF
+  MACROLET (lwlib_uses_motif);
+#else
+  MACROLET (lwlib_does_not_use_motif);
+#endif
+#if (XmVersion >= 1002)
+  MACROLET (lwlib_uses_motif_1_2);
+#else
+  MACROLET (lwlib_does_not_use_motif_1_2);
+#endif
+#ifdef LWLIB_MENUBARS_LUCID
+  MACROLET (lwlib_menubars_lucid);
+#elif defined (HAVE_MENUBARS)
+  MACROLET (lwlib_menubars_motif);
+#endif
+#ifdef LWLIB_SCROLLBARS_LUCID
+  MACROLET (lwlib_scrollbars_lucid);
+#elif defined (LWLIB_SCROLLBARS_MOTIF)
+  MACROLET (lwlib_scrollbars_motif);
+#elif defined (HAVE_SCROLLBARS)
+  MACROLET (lwlib_scrollbars_athena);
+#endif
+#ifdef LWLIB_DIALOGS_MOTIF
+  MACROLET (lwlib_dialogs_motif);
+#elif defined (HAVE_DIALOGS)
+  MACROLET (lwlib_dialogs_athena);
+#endif
+#ifdef LWLIB_WIDGETS_MOTIF
+  MACROLET (lwlib_widgets_motif);
+#elif defined (HAVE_WIDGETS)
+  MACROLET (lwlib_widgets_athena);
+#endif
+
+#undef MACROLET
+}
+
+void
+syms_of_gui_x (void)
+{
+  defsymbol (&Qmenu_no_selection_hook, "menu-no-selection-hook");
+}
+
+void
+reinit_vars_of_gui_x (void)
+{
+  lwlib_id_tick = (1<<16);	/* start big, to not conflict with Energize */
+#ifdef HAVE_POPUPS
+  popup_up_p = 0;
+#endif
+
+  /* this makes only safe calls as in emacs.c */
+  sanity_check_lwlib ();
+}
+
+void
+vars_of_gui_x (void)
+{
+  reinit_vars_of_gui_x ();
+
+  Vpopup_callbacks = Qnil;
+  staticpro (&Vpopup_callbacks);
+
+#if 0
+  /* This DEFVAR_LISP is just for the benefit of make-docfile. */
+  /* #### misnamed */
+  DEFVAR_LISP ("menu-no-selection-hook", &Vmenu_no_selection_hook /*
+Function or functions to call when a menu or dialog box is dismissed
+without a selection having been made.
+*/ );
+#endif
+  Fset (Qmenu_no_selection_hook, Qnil);
+}