/*
 * $Header: /home/campbell/Languages/Scheme/scm/x-scm/RCS/xt.c,v 1.15 1992/08/17 04:06:02 campbell Beta $
 *
 * Author: Larry Campbell (campbell@redsox.bsw.com)
 *
 * Copyright 1992 by The Boston Software Works, Inc.
 * Permission to use for any purpose whatsoever granted, as long
 * as this copyright notice remains intact.  Please send bug fixes
 * or enhancements to the above email address.
 *
 * X Toolkit interface for scm
 */

#include <stdio.h>
#include <X11/Intrinsic.h>
#include <X11/StringDefs.h>
#include <X11/IntrinsicP.h>
#include <X11/Core.h>
#include <X11/CoreP.h>
#include <X11/Shell.h>

#ifdef MOTIF
#include <Xm/Xm.h>
#endif

#include "scm.h"
#include "x.h"
#include "xt.h"

static char s_xt_add_callback[]			= "xt:add-callback";
static char s_xt_add_event_handler[]		= "xt:add-event-handler";
static char s_xt_add_time_out[]			= "xt:add-time-out";
static char s_xt_add_work_proc[]		= "xt:add-work-proc";
static char s_xt_app_create_shell[]		= "xt:app-create-shell";
static char s_xt_class[]			= "xt:class";
static char s_xt_class_name[]			= "xt:class-name";
static char s_xt_class_subclassp[]		= "xt:class-subclass?";
static char s_xt_class_superclass[]		= "xt:class-superclass";
static char s_xt_create_managed_widget[]	= "xt:create-managed-widget";
static char s_xt_create_popup_shell[]		= "xt:create-popup-shell";
static char s_xt_create_widget[]		= "xt:create-widget";
static char s_xt_destroy_widget[]		= "xt:destroy-widget";
static char s_xt_dispatch_event[]		= "xt:dispatch-event";
static char s_xt_display[]			= "xt:display";

/* identifier truncated to 31 characters to shut certain C compilers up */
static char s_xt_get_constraint_resource_li[]	= "xt:get-constraint-resource-list";

static char s_xt_get_resource_list[]		= "xt:get-resource-list";
static char s_xt_get_value[]			= "xt:get-value";
static char s_xt_initialize[]			= "xt:initialize";
static char s_xt_is_realized[]			= "xt:is-realized";
static char s_xt_main_loop[]			= "xt:main-loop";
static char s_xt_manage_children[]		= "xt:manage-children";
static char s_xt_map_widget[]			= "xt:map-widget";
static char s_xt_move_widget[]			= "xt:move-widget";
static char s_xt_name[]				= "xt:name";
static char s_xt_next_event[]			= "xt:next-event";
static char s_xt_parent[]			= "xt:parent";
static char s_xt_popdown[]			= "xt:popdown";
static char s_xt_popup[]			= "xt:popup";
static char s_xt_realize_widget[]		= "xt:realize-widget";
static char s_xt_remove_event_handler[]		= "xt:remove-event-handler";
static char s_xt_remove_time_out[]		= "xt:remove-time-out";
static char s_xt_remove_work_proc[]		= "xt:remove-work-proc";
static char s_xt_set_sensitive[]		= "xt:set-sensitive";
static char s_xt_set_values[]			= "xt:set-values";
static char s_xt_subclassp[]			= "xt:subclass?";
static char s_xt_superclass[]			= "xt:superclass";
static char s_xt_unmanage_children[]		= "xt:unmanage-children";
static char s_xt_unmap_widget[]			= "xt:unmap-widget";
static char s_xt_unrealize_widget[]		= "xt:unrealize-widget";
static char s_xt_window[]			= "xt:window";

static char s_xt_widget_class_map[]		= "*widget-class-map*";

static SCM *loc_class_map;

/* forward declarations */
void xt__make_arglist();
static SCM xt__make_resource_list();

xt_widget_class_t xt_widget_classes[] = {
    "xt:application-shell",	&applicationShellWidgetClass,
    "xt:composite",		&compositeWidgetClass,
    "xt:constraint",		&constraintWidgetClass,
    "xt:core",			&coreWidgetClass,
    "xt:override-shell",	&overrideShellWidgetClass,
    "xt:shell",			&shellWidgetClass,
    "xt:top-level-shell",	&topLevelShellWidgetClass,
    "xt:transient-shell",	&transientShellWidgetClass,
    "xt:wm-shell",		&wmShellWidgetClass
};

#define MAKFROMSTR(s) (makfromstr(s, strlen(s)))

static SCM xt__class_equalp();
static SCM xt__widget_equalp();

/*
 * Scheme types defined in this module
 */

#define XT_SMOBS							  \
XX(widget,		mark_no_further,	free0, xt__widget_equalp) \
XX(widget_class,	mark_no_further,	free0, xt__class_equalp)

#undef XX
#define XX(name, mark, free, equalp)		\
long TOKEN_PASTE(tc16_,name);			\
static int TOKEN_PASTE(print_,name)();		\
static smobfuns TOKEN_PASTE(smob,name) =	\
    { mark, free, TOKEN_PASTE(print_,name), equalp };

XT_SMOBS


SCM make_widget(w)
{
  SCM sw;
  NEWCELL(sw);
  DEFER_INTS;
  CAR(sw) = tc16_widget;
  SETCDR(sw,w);
  ALLOW_INTS;
  return sw;
}

SCM make_widget_class(c)
WidgetClass c;
{
  SCM w;
  NEWCELL(w);
  DEFER_INTS;
  CAR(w) = tc16_widget_class;
  SETCDR(w, c);
  ALLOW_INTS;
  return w;
}

static SCM xt__class_equalp(x, y)
SCM x, y;
{
  if (CDR(x) == CDR(y))
    return BOOL_T;
  else
    return BOOL_F;
}

static SCM xt__widget_equalp(x, y)
SCM x, y;
{
  if (CDR(x) == CDR(y))
    return BOOL_T;
  else
    return BOOL_F;
}


static SCM *loc_callbacks;

static void protect_callback(proc)
SCM proc;
{
  if (memq(proc, *loc_callbacks) != BOOL_F)
    return;
  *loc_callbacks = cons(proc, *loc_callbacks);
}


SCM xt_destroy_widget(sw)
SCM sw;
{
  ASSERT(NIMP(sw) && WIDGETP(sw), sw, ARG1, s_xt_map_widget);
  XtDestroyWidget(WIDGET(sw));
  return UNSPECIFIED;
}

SCM xt_initialize(sname, sclass, args)
SCM sname, sclass, args;
{
  Widget top_level;
  char *argv[1];
  int argc;

  ASSERT(NIMP(sname) && STRINGP(sname), args, ARG1, s_xt_initialize);
  ASSERT(NIMP(sclass) && STRINGP(sclass), args, ARG2, s_xt_initialize);

  argv[0] = CHARS(sname);
  argc = 1;
  top_level = XtInitialize(CHARS(sname), CHARS(sclass), 0, 0, &argc, argv);

  ASSERT(top_level != 0, sname, "XtInitialize error", s_xt_initialize);

  return make_widget(top_level);
}


SCM xt_app_create_shell(sname, sclass, args)
SCM sname, sclass, args;
{
  Widget shell;
  SCM swc;
  SCM sdisplay;
  Display *display;
  char *argv[1];
  int argc;

  ASSERT(NIMP(sname) && STRINGP(sname), args, ARG1, s_xt_app_create_shell);
  ASSERT(NIMP(sclass) && STRINGP(sclass), args, ARG2, s_xt_app_create_shell);
  ASSERT(NIMP(args) && CONSP(args), args, ARG3, s_xt_app_create_shell);
  swc = CAR(args);
  args = CDR(args);
  ASSERT(NIMP(swc) && WIDGETCLASSP(swc), swc, ARG3, s_xt_app_create_shell);
  ASSERT(NIMP(args) && CONSP(args), args, ARG3, s_xt_app_create_shell);
  sdisplay = CAR(args);
  ASSERT(NIMP(sdisplay) && XDISPLAYP(sdisplay), sdisplay,  ARG4, s_xt_app_create_shell);
  display = (Display *) CDR(sdisplay);
  argv[0] = CHARS(sname);
  argc = 1;
  shell = XtAppCreateShell(
    CHARS(sname),
    CHARS(sclass),
    WIDGETCLASS(swc),
    display,
    0,
    0);

  ASSERT(shell != 0, sname, "XtAppCreateShell error", s_xt_app_create_shell);

  return make_widget(shell);
}


SCM xt_class(sw)
SCM sw;
{
  ASSERT(NIMP(sw) && WIDGETP(sw), sw, ARG1, s_xt_class);
  return make_widget_class(XtClass(WIDGET(sw)));
}


SCM xt_class_name(swc)
SCM swc;
{
  char *p;
  ASSERT(NIMP(swc) && WIDGETCLASSP(swc), swc, ARG1, s_xt_class_name);
  p = WIDGETCLASS(swc)->core_class.class_name;
  return MAKFROMSTR(p);
}


static Boolean xt_work_proc_handler(proc)
SCM proc;
{
  SCM result = apply(proc, EOL, EOL);
  if (result != BOOL_F && result != BOOL_T) {
    fprintf(stderr, "warning: procedure registered by xt:add-work-proc must return #t or #f\n");
    result = BOOL_T;
  }
  return (result == BOOL_T);
}


SCM xt_add_work_proc(proc)
SCM proc;
{
  ASSERT(NIMP(proc) && CLOSUREP(proc), proc, ARG1, s_xt_add_work_proc);
  return MAKINUM(XtAddWorkProc(xt_work_proc_handler, proc));
}


static void xt_time_out_handler(proc)
SCM proc;
{
  (void) apply(proc, EOL, EOL);
}


SCM xt_add_time_out(interval, proc)
SCM interval, proc;
{
  ASSERT(INUMP(interval) && INUM(interval) > 0, interval, ARG1, s_xt_add_time_out);
  ASSERT(NIMP(proc) && CLOSUREP(proc), proc, ARG2, s_xt_add_time_out);
  return MAKINUM(XtAddTimeOut(INUM(interval), xt_time_out_handler, proc));
}


SCM xt_remove_time_out(id)
SCM id;
{
  ASSERT(INUMP(id), id, ARG1, s_xt_remove_time_out);
  XtRemoveTimeOut(INUM(id));
  return UNSPECIFIED;
}


SCM xt_remove_work_proc(id)
SCM id;
{
  ASSERT(INUMP(id), id, ARG1, s_xt_remove_work_proc);
  XtRemoveWorkProc(INUM(id));
  return UNSPECIFIED;
}


/* This routine implements XtCreate(Managed)Widget */
 
static SCM xt__create_a_widget(sname, sclass, args, rtn, name)
SCM sname, sclass, args;
Widget (rtn)();
char *name;
{
  SCM sparent;
  Widget parent;
  Widget w;
  Arg *arglist;
  int n;

  ASSERT(NIMP(sname) && STRINGP(sname), sname, ARG1, name);
  ASSERT(NIMP(sclass) && WIDGETCLASSP(sclass), sclass, ARG2, name);
  ASSERT(NIMP(args) && CONSP(args), args, ARG3, name);
  sparent = CAR(args); args = CDR(args);
  ASSERT(NIMP(sparent) && WIDGETP(sparent), sparent, ARG3, name);

  xt__make_arglist(args, &arglist, &n, name);

  w = rtn(CHARS(sname), CHARS(sclass), WIDGET(sparent), arglist, n);

  if (arglist) free(arglist);

  return make_widget(w);
}


SCM xt_create_managed_widget(sname, sclass, args)
SCM sname, sclass, args;
{
  return xt__create_a_widget(
    sname, sclass, args, XtCreateManagedWidget, s_xt_create_managed_widget);
}


SCM xt_create_widget(sname, sclass, args)
SCM sname, sclass, args;
{
  return xt__create_a_widget(
    sname, sclass, args, XtCreateWidget, s_xt_create_widget);
}


SCM xt_create_popup_shell(sname, sclass, args)
SCM sname, sclass, args;
{
  SCM sparent;
  Widget parent;
  Widget w;
  Arg *arglist;
  int n;

  ASSERT(NIMP(sname) && STRINGP(sname), sname, ARG1, s_xt_create_popup_shell);
  ASSERT(NIMP(sclass) && WIDGETCLASSP(sclass), sclass, ARG2, s_xt_create_popup_shell);
  ASSERT(NIMP(args) && CONSP(args), args, ARG3, s_xt_create_popup_shell);
  sparent = CAR(args); args = CDR(args);
  ASSERT(NIMP(sparent) && WIDGETP(sparent), sparent, ARG4, s_xt_create_popup_shell);

  xt__make_arglist(args, &arglist, &n, s_xt_create_popup_shell);

  w = XtCreatePopupShell(CHARS(sname), CHARS(sclass), WIDGET(sparent), arglist, n);

  if (arglist) free(arglist);

  return make_widget(w);
}


SCM xt_move_widget(sw, sx, sy)
SCM sw, sx, sy;
{
  ASSERT(NIMP(sw) && WIDGETP(sw), sw, ARG1, s_xt_move_widget);
  ASSERT(INUMP(sx), sx, ARG2, s_xt_move_widget);
  ASSERT(INUMP(sy), sy, ARG3, s_xt_move_widget);
  XtMoveWidget(WIDGET(sw), INUM(sx), INUM(sy));
  return UNSPECIFIED;
}


SCM xt_map_widget(sw)
SCM sw;
{
  ASSERT(NIMP(sw) && WIDGETP(sw), sw, ARG1, s_xt_map_widget);
  XtMapWidget(WIDGET(sw));
  return UNSPECIFIED;
}


static void xt__make_widget_list(wlp, np, args, name)
WidgetList *wlp;
int *np;
SCM args;
char *name;
{
  int i, n;
  SCM sw;

  ASSERT(NIMP(args) && CONSP(args), args, ARG1, name);
  n = ilength(args);
  *np = n;
  if (!n) return;
  *wlp = (WidgetList) must_malloc(n * sizeof(Widget), name);
  for (i = 0; i < n; i++) {
    ASSERT(NIMP(args) && CONSP(args), args, "improper arg list", name);
    sw = CAR(args);
    args = CDR(args);
    ASSERT(NIMP(sw) && WIDGETP(sw), sw, "must be a widget", name);
    (*wlp)[i] = WIDGET(sw);
  }
}


SCM xt_manage_children(args)
SCM args;
{
  WidgetList wl;
  int n;
  xt__make_widget_list(&wl, &n, args, s_xt_manage_children);
  if (n)
    XtManageChildren(wl, n);
  return UNSPECIFIED;
}


/*
 * The standard X Toolkit functions XtIsSubclass and XtSuperclass
 * stupidly take widgets, not classes, making them useless for walking
 * up the class hierarchy.  I was tempted to make xt:subclass? and
 * xt:superclass do the right thing, but decided it might confuse people
 * used to the original functions, so instead I called the useful
 * functions xt:class-subclass? and xt:class-superclass.
 */

SCM xt_subclassp(sw, swc)
SCM sw;
SCM swc;
{
  ASSERT(NIMP(sw) && WIDGETP(sw), sw, ARG1, s_xt_subclassp);
  ASSERT(NIMP(swc) && WIDGETCLASSP(swc), swc, ARG1, s_xt_subclassp);

  if (XtIsSubclass(WIDGET(sw), WIDGETCLASS(swc)))
    return BOOL_T;
  else
    return BOOL_F;
}

SCM xt_class_subclassp(swt, swc)
SCM swt;
SCM swc;
{
  WidgetClass x, c;

  ASSERT(NIMP(swt) && WIDGETCLASSP(swt), swt, ARG1, s_xt_class_subclassp);
  ASSERT(NIMP(swc) && WIDGETCLASSP(swc), swc, ARG1, s_xt_class_subclassp);
  c = WIDGETCLASS(swc);

  for (x = WIDGETCLASS(swt); x; x = x->core_class.superclass) {
    if (x == c)
      return BOOL_T;
  }
  return BOOL_F;
}


SCM xt_superclass(sw)
SCM sw;
{
  ASSERT(NIMP(sw) && WIDGETP(sw), sw, ARG1, s_xt_superclass);
  return make_widget_class(XtSuperclass(WIDGET(sw)));
}


SCM xt_class_superclass(scw)
SCM scw;
{
  ASSERT(NIMP(scw) && WIDGETCLASSP(scw), scw, ARG1, s_xt_class_superclass);
  return make_widget_class(WIDGETCLASS(scw)->core_class.superclass);
}


SCM xt_unmanage_children(args)
SCM args;
{
  WidgetList wl;
  int n;
  xt__make_widget_list(&wl, &n, args, s_xt_unmanage_children);
  if (n)
    XtUnmanageChildren(wl, n);
  return UNSPECIFIED;
}


SCM xt_unmap_widget(sw)
SCM sw;
{
  ASSERT(NIMP(sw) && WIDGETP(sw), sw, ARG1, s_xt_unmap_widget);
  XtUnmapWidget(WIDGET(sw));
  return UNSPECIFIED;
}


SCM xt_unrealize_widget(sw)
SCM sw;
{
  ASSERT(NIMP(sw) && WIDGETP(sw), sw, ARG1, s_xt_unrealize_widget);
  XtUnrealizeWidget(WIDGET(sw));
  return UNSPECIFIED;
}


SCM xt_name(sw)
SCM sw;
{
  ASSERT(NIMP(sw) && WIDGETP(sw), sw, ARG1, s_xt_name);
  return MAKFROMSTR(XtName(WIDGET(sw)));
}


SCM xt_parent(sw)
SCM sw;
{
  Widget parent;
  ASSERT(NIMP(sw) && WIDGETP(sw), sw, ARG1, s_xt_parent);
  parent = XtParent(WIDGET(sw));
  if (parent)
    return make_widget(parent);
  else
    return BOOL_F;
}


SCM xt_popdown(sw)
SCM sw;
{
  ASSERT(NIMP(sw) && WIDGETP(sw), sw, ARG1, s_xt_popdown);
  XtPopdown(WIDGET(sw));
  return UNSPECIFIED;
}

SCM xt_popup(sw, sgrab)
SCM sw, sgrab;
{
  ASSERT(NIMP(sw) && WIDGETP(sw), sw, ARG1, s_xt_popup);
  ASSERT(INUMP(sgrab), sgrab, ARG2, s_xt_popup);
  XtPopup(WIDGET(sw), INUM(sgrab));
  return UNSPECIFIED;
}

void xt__make_arglist(args, arglistp, np, caller_name)
SCM    args;
Arg **arglistp;
int   *np;
char  *caller_name;
{
  Arg *arglist;
  int l, n;
  SCM sname, svalue;
  char *name;
  XtArgVal value;

  l = ilength(args) / 2;
  arglist = 0;
  n = 0;
  if (l > 0) {
    arglist = (Arg *) must_malloc(l * sizeof(Arg), caller_name);
    for (n = 0; n < l; n++) {
      ASSERT(NIMP(args) && CONSP(args), args, ARG1, caller_name);
      sname = CAR(args); args = CDR(args);
      ASSERT(NIMP(args) && CONSP(args), args, ARG1, caller_name);
      svalue = CAR(args); args = CDR(args);
      ASSERT(NIMP(sname) && STRINGP(sname), sname, ARG1, caller_name);
      name = CHARS(sname);

      if (svalue == BOOL_F)
	value = (XtArgVal) FALSE;
      else if (svalue == BOOL_T)
	value = (XtArgVal) TRUE;
      else
#ifdef MOTIF
      if (NIMP(svalue) && (XMSTRINGP(svalue) || XMSTRINGTABLEP(svalue)))
	value = (XtArgVal) XMSTRING(svalue);
      else
#endif
      if (NIMP(svalue) && (STRINGP(svalue) || WIDGETP(svalue)))
	value = (XtArgVal) CHARS(svalue);
      else if (INUMP(svalue))
	value = (XtArgVal) INUM(svalue);
      else
        ASSERT(0, svalue, "invalid resource type", caller_name);

      XtSetArg(arglist[n], name, value);
    }
  }
  *arglistp = arglist;
  *np = n;
}


SCM xt_realize_widget(sw)
SCM sw;
{
  ASSERT(NIMP(sw) && WIDGETP(sw), sw, ARG1, s_xt_realize_widget);
  XtRealizeWidget(WIDGET(sw));
  return UNSPECIFIED;
}


SCM xt_dispatch_event(se)
SCM se;
{
  ASSERT(NIMP(se) && XEVENTP(se), se, ARG1, s_xt_dispatch_event);
  return XtDispatchEvent(XEVENT(se)) ? BOOL_T : BOOL_F;
}


SCM xt_display(sw)
SCM sw;
{
  SCM sd;

  ASSERT(NIMP(sw) && WIDGETP(sw), sw, ARG1, s_xt_display);
  sw = make_xdisplay(XtDisplay(WIDGET(sw)));
  return sw;
}


SCM xt_window(sw)
SCM sw;
{
  Widget widget;

  ASSERT(NIMP(sw) && WIDGETP(sw), sw, ARG1, s_xt_window);
  widget = WIDGET(sw);
  ASSERT(XtIsRealized(widget), sw, "widget is not realized", s_xt_window);
  sw = make_xwindow(XtWindow(widget));
  return sw;
}

SCM xt_is_realized(sw)
SCM sw;
{
  ASSERT(NIMP(sw) && WIDGETP(sw), sw, ARG1, s_xt_is_realized);
  return XtIsRealized(WIDGET(sw)) ? BOOL_T : BOOL_F;
}


/*
 * Temporary kludge: Xt keels over pretty rapidly if you call
 * XtMainLoop recursively (i.e., from a callback or event handler).
 * We need to prevent this, but also need to allow XtMainLoop to
 * be reentered if we get thrown out because an error occurred.
 * Doing this properly requires cooperation with scm's top level,
 * but I don't have time to do that right now.  So, this hack:
 * xt:main-loop should ordinarily be called with no arguments, but
 * if you call it with the single argument #t, it will bypass the
 * recursion check.
 */

SCM xt_main_loop(args)
{
  static Bool running;
  if (NIMP(args) && CONSP(args) && (CAR(args) == BOOL_T))
    running = FALSE;
  ASSERT(!running, UNDEFINED, "xt:main-loop already running", s_xt_main_loop);
  running = TRUE;
  XtMainLoop();
  return UNSPECIFIED;
}

void xt_event_handler(w, proc, event, continue_to_dispatch)
Widget w;
XtPointer proc;
XEvent *event;
Boolean *continue_to_dispatch;
{
  SCM sproc = (SCM) proc;
  SCM se, sw, args;

  se = make_xevent(event);
  sw = make_widget(w);
  args = cons(se, EOL);
  args = cons(args, EOL);
  
  apply(proc, sw, args);
}


SCM xt_add_event_handler(sw, smask, args)
SCM sw, smask, args;
{
  SCM snonmaskable;
  SCM proc;

  ASSERT(NIMP(sw) && WIDGETP(sw), sw, ARG1, s_xt_add_event_handler);
  ASSERT(INUMP(smask), smask, ARG2, s_xt_add_event_handler);
  ASSERT(NIMP(args) && CONSP(args), args, ARG3, s_xt_add_event_handler);
  snonmaskable = CAR(args); args = CDR(args);
  ASSERT(INUMP(snonmaskable), snonmaskable, ARG4, s_xt_add_event_handler);
  ASSERT(NIMP(args) && CONSP(args), args, ARG5, s_xt_add_event_handler);
  proc = CAR(args);

  protect_callback(proc);

  XtAddEventHandler(WIDGET(sw), INUM(smask), INUM(snonmaskable), xt_event_handler, proc);

  return UNSPECIFIED;
}


static void xt_callback_handler(w, proc, data)
Widget w;
XtPointer proc, data;
{
  SCM sw;
  SCM sproc = (SCM) proc;

  sw = make_widget(w);
  apply(proc, sw, listofnull);
}


SCM xt_remove_event_handler(sw, smask, args)
SCM sw, smask, args;
{
  SCM snonmaskable;
  SCM proc;

  ASSERT(NIMP(sw) && WIDGETP(sw), sw, ARG1, s_xt_remove_event_handler);
  ASSERT(INUMP(smask), smask, ARG2, s_xt_remove_event_handler);
  ASSERT(NIMP(args) && CONSP(args), args, ARG3, s_xt_remove_event_handler);
  snonmaskable = CAR(args); args = CDR(args);
  ASSERT(INUMP(snonmaskable), snonmaskable, ARG4, s_xt_remove_event_handler);
  ASSERT(NIMP(args) && CONSP(args), args, ARG5, s_xt_remove_event_handler);
  proc = CAR(args);

  XtRemoveEventHandler(WIDGET(sw), INUM(smask), INUM(snonmaskable), xt_event_handler, proc);

  return UNSPECIFIED;
}


SCM xt_add_callback(sw, sname, args)
SCM sw, sname, args;
{
  SCM proc;

  ASSERT(NIMP(sw) && WIDGETP(sw), sw, ARG1, s_xt_add_callback);
  ASSERT(NIMP(sname) && STRINGP(sname), sname, ARG2, s_xt_add_callback);
  ASSERT(NIMP(args) && CONSP(args), args, "consp", s_xt_add_callback);
  proc = CAR(args);
  ASSERT(NIMP(proc) && CLOSUREP(proc), proc, "closurep", s_xt_add_callback);

  protect_callback(proc);

  XtAddCallback(WIDGET(sw), CHARS(sname), xt_callback_handler, proc);

  return UNSPECIFIED;
}


static SCM xt__make_resource_object(p, type)
char *p, *type;
{
  SCM s;

  if (!p)
    return EOL;
  if (strcmp(type, "Boolean") == 0)
    return (*((Boolean *) p)) ? BOOL_T : BOOL_F;
  if ( (strcmp(type, "Int") == 0) ||
       (strcmp(type, "VerticalInt") == 0) ||
       (strcmp(type, "HorizontalInt") == 0)
     )
    return MAKINUM(*((int *) p));
  if ( (strcmp(type, "Short") == 0) ||
       (strcmp(type, "VerticalDimension") == 0) ||
       (strcmp(type, "HorizontalDimension") == 0) ||
       (strcmp(type, "VerticalPosition") == 0) ||
       (strcmp(type, "HorizontalPosition") == 0)
     )
    return MAKINUM(*((short *) p));
  if (strcmp(type, "String") == 0)
    return MAKFROMSTR(p);
#ifdef MOTIF
  if (strcmp(type, "XmString") == 0) {
    s = make_xmstring();
    SETCDR(s, XmStringCreateLtoR(CHARS(p), XmSTRING_DEFAULT_CHARSET));
    return s;
  }
#endif
  return EOL;
}


SCM xt_get_resource_list(swc)
SCM swc;
{
  XtResourceList resources;
  Cardinal n;
  SCM result;

  ASSERT(NIMP(swc) && WIDGETCLASSP(swc), swc, ARG1, s_xt_get_resource_list);
  XtGetResourceList(WIDGETCLASS(swc), &resources, &n);
  result = xt__make_resource_list(resources, n);
  XtFree(resources);
  return result;
}

SCM xt_get_constraint_resource_list(swc)
SCM swc;
{
  XtResourceList resources;
  Cardinal n;
  SCM result;

  ASSERT(NIMP(swc) && WIDGETCLASSP(swc), swc, ARG1, s_xt_get_constraint_resource_li);
  XtGetConstraintResourceList(WIDGETCLASS(swc), &resources, &n);
  result = xt__make_resource_list(resources, n);
  XtFree(resources);
  return result;
}


/*
 * This routine stinks, but so does the X Toolkit's handling of resource
 * data types.  This code will only work on machines that are reasonably
 * VAX-like.  If you fix it, please send me the improved code!
 */

static SCM xt__make_resource_list(resources, n)
XtResourceList resources;
Cardinal n;
{
  Cardinal i;
  int size, x;
  SCM result, item, name, class, stype, ssize, sdeftype, defvalue;
  char *p, *type, *deftype;

  if (n == 0)
    return EOL;
  result = EOL;
  for (i = 0; i < n; i++) {
    name  = MAKFROMSTR(resources[i].resource_name);
    class = MAKFROMSTR(resources[i].resource_class);
    type = resources[i].resource_type;
    stype  = MAKFROMSTR(type);
    size = resources[i].resource_size;
    ssize  = MAKINUM(size);
    deftype = resources[i].default_type;
    sdeftype = MAKFROMSTR(deftype);
    if (strcmp(deftype, "Immediate") == 0) {
      p = (char *) &resources[i].default_addr;
      deftype = type;
    } else
      p = resources[i].default_addr;
    defvalue = xt__make_resource_object(p, deftype);
    item  = cons(name, cons(class, cons(stype, cons(ssize, cons(sdeftype, cons(defvalue, EOL))))));
    result = cons(item, result);
  }
  return result;
}


/*
 * When fetching resources we have to be told what kind of Scheme
 * object to turn the value into.  The following is a table of type
 * name symbols.
 */

static SCM xt_make_boolean();
static SCM xt_make_char();
static SCM xt_make_integer();
static SCM xt_make_short();
static SCM xt_make_unsigned_char();
static SCM xt_make_unsigned_short();
static SCM xt_make_string();
static SCM xt_make_widget();
static SCM xt_make_widgetlist();

#ifdef MOTIF
static SCM xt_make_xmstring();
static SCM xt_make_xmstringtable();
#endif

static struct {
  char *name;
  SCM sym;
  SCM (*maker)();
} type_table[] = {
    {"xt:boolean",       0, xt_make_boolean},
    {"xt:char",		 0, xt_make_char},
    {"xt:integer",       0, xt_make_integer},
    {"xt:short",	 0, xt_make_short},
    {"xt:string",        0, xt_make_string},
    {"xt:unsigned-char", 0, xt_make_unsigned_char},
    {"xt:unsigned-short",0, xt_make_unsigned_short},
    {"xt:widget",        0, xt_make_widget},
    {"xt:widgetlist",    0, xt_make_widgetlist},
#ifdef MOTIF
    {"xt:xmstring",      0, xt_make_xmstring},
    {"xt:xmstringtable", 0, xt_make_xmstringtable},
#endif
};

static void xt_init_resource_types()
{
  int i;
  SCM s;

  for (i = 0; i < XtNumber(type_table); i++) {
    s = sysintern(type_table[i].name, UNDEFINED);
    type_table[i].sym = CAR(s);
    CDR(s) = CAR(s);
  }
}

SCM xt_get_value(sw, sname, args)
SCM sw, sname, args;
{
  SCM stype;
  Arg arg[1];
  XtArgVal value;
  int i;

  ASSERT(NIMP(sw) && WIDGETP(sw), sw, ARG1, s_xt_get_value);
  ASSERT(NIMP(sname) && STRINGP(sname), sname, ARG2, s_xt_get_value);
  ASSERT(NIMP(args) && CONSP(args), args, ARG3, s_xt_get_value);
  stype = CAR(args);
  ASSERT(NIMP(stype) && SYMBOLP(stype), stype, ARG3, s_xt_get_value);
  args = CDR(args);
  
  XtSetArg(arg[0], CHARS(sname), &value);
  value = 0;
  XtGetValues(WIDGET(sw), arg, 1);

  for (i = 0; i < XtNumber(type_table); i++) {
    if (stype == type_table[i].sym)
      return type_table[i].maker(value, args);
  }
  return UNSPECIFIED;
}

static SCM xt_make_char(value, args)
XtArgVal value;
SCM args;
{
  char *p = (char *) &value;
  return MAKINUM((int) *p);
}

static SCM xt_make_integer(value, args)
XtArgVal value;
SCM args;
{
  return MAKINUM((int) value);
}

static SCM xt_make_short(value, args)
XtArgVal value;
SCM args;
{
  short *p = (short *) &value;
  return MAKINUM(*p);
}

static SCM xt_make_unsigned_char(value, args)
XtArgVal value;
SCM args;
{
  unsigned char *p = (unsigned char *) &value;
  return MAKINUM((int) *p);
}

static SCM xt_make_unsigned_short(value, args)
XtArgVal value;
SCM args;
{
  unsigned short *p = (unsigned short *) &value;
  return MAKINUM((int) *p);
}

static SCM xt_make_boolean(value, args)
XtArgVal value;
SCM args;
{
  if (value)
    return BOOL_T;
  else
    return BOOL_F;
}

static SCM xt_make_string(value, args)
XtArgVal value;
SCM args;
{
  if (value == 0)
    return makstr(0);
  else
    return MAKFROMSTR((char *) value);
}

static SCM xt_make_widget(value, args)
XtArgVal value;
SCM args;
{
 if (value)
   return make_widget((Widget) value);
 else
   return BOOL_F;
}

static SCM xt_make_widgetlist(value, args)
XtArgVal value;
SCM args;
{
  SCM slen;
  SCM s;
  int i;
  SCM *dst;
  WidgetList src = (WidgetList) value;

  ASSERT(NIMP(args) && CONSP(args), args, ARG4, s_xt_get_value);
  slen = CAR(args);
  ASSERT(INUMP(slen), slen, ARG4, s_xt_get_value);
  s = make_vector(slen, UNDEFINED);
  dst = VELTS(s);
  for (i = 0; i < INUM(slen); i++)
    dst[i] = make_widget(src[i]);
  return s;
}

#ifdef MOTIF
static SCM xt_make_xmstring(value, args)
XtArgVal value;
SCM args;
{
  SCM s;
  s = make_xmstring();
  if (value == 0) {
    SETCDR(s, XmStringCreate("", XmSTRING_DEFAULT_CHARSET));
    return s;
  }
  SETCDR(s, (char *) XmStringCopy((XmString) value));
  return s;
}

static SCM xt_make_xmstringtable(value, args)
XtArgVal value;
SCM args;
{
  SCM slen;
  SCM s;
  int i;
  XmStringTable dst;
  XmStringTable src = (XmStringTable) value;

  ASSERT(NIMP(args) && CONSP(args), args, ARG4, s_xt_get_value);
  slen = CAR(args);
  ASSERT(INUMP(slen), slen, ARG4, s_xt_get_value);
  s = make_xmstringtable(INUM(slen));
  dst = (XmString *) CDR(s);
  for (i = 0; i < INUM(slen); i++)
    dst[i] = XmStringCopy(src[i]);
  return s;
}
#endif /* MOTIF */


SCM xt_next_event()
{
  XEvent e;

  XtNextEvent(&e);
  return make_xevent(&e);
}


SCM xt_set_sensitive(sw, ss)
SCM sw, ss;
{
  ASSERT(NIMP(sw) && WIDGETP(sw), sw, ARG1, s_xt_set_sensitive);
  ASSERT(ss == BOOL_F || ss == BOOL_T, ss, ARG2, s_xt_set_sensitive);
  XtSetSensitive(WIDGET(sw), ss == BOOL_F ? FALSE : TRUE);
  return UNSPECIFIED;
}


SCM xt_set_values(args)
SCM args;
{
  SCM sw;
  ArgList arglist;
  int n;

  ASSERT(NIMP(args) && CONSP(args), args, ARG1, s_xt_set_values);
  sw = CAR(args); args = CDR(args);
  ASSERT(NIMP(sw) && WIDGETP(sw), sw, ARG1, s_xt_set_values);
  ASSERT(NIMP(args), args, ARG2, s_xt_set_values);
  xt__make_arglist(args, &arglist, &n, s_xt_set_values);
  if (n) {
    XtSetValues(WIDGET(sw), arglist, n);
  }

  return UNSPECIFIED;
}


static int print_widget_class(exp, f, writing)
SCM exp;
FILE *f;
int writing;
{
#if 0
  lputs("#<widget class ",f);
  lputs(WIDGETCLASS(exp)->core_class.class_name,f);
  lputc('>',f);
#else
  SCM s;
  s = assoc(exp, *loc_class_map);
  if (s == BOOL_F || IMP(s) || NCONSP(s))
    lputs("#<unknown or invalid widget class>", f);
  else {
    lputs("#.(begin \"widget class\" ", f);
    iprin1(CDR(s), f, writing);
    lputc(')', f);
  }
#endif
  return 1;
}

static int print_widget(exp, f, writing)
SCM exp;
FILE *f;
int writing;
{
  lputs("#<",f);
  lputs(XtClass(WIDGET(exp))->core_class.class_name,f);
  lputs(" widget",f);
  if (XtIsSubclass(WIDGET(exp), coreWidgetClass)) {
    lputs(" \"",f);
    lputs(WIDGET(exp)->core.name,f);
    lputc('"',f);
  }
  lputs(" #x",f);
  intprint((long) WIDGET(exp),16,f);
  if (XtIsRealized(WIDGET(exp)))
    lputs(", is realized",f);
  if (XtIsManaged(WIDGET(exp)))
    lputs(", is managed",f);
  lputc('>',f);
  return 1;
}


void xt_init_widget_classes(table, count, list_name)
xt_widget_class_t table[];
int count;
char *list_name;
{
  int i;
  SCM s;
  SCM class;
  SCM class_list;

  class_list = EOL;
  for (i = 0; i < count; i++) {
    class = make_widget_class(*(table[i].wc_class));
    s = sysintern(table[i].wc_name, class);
    class_list = cons(class, class_list);
    *loc_class_map = cons(cons(CDR(s), CAR(s)), *loc_class_map);
  }
  s = sysintern(list_name, class_list);
}


iproc xt_lsubr2s[] = {
  {s_xt_add_callback,		xt_add_callback},
  {s_xt_add_event_handler,	xt_add_event_handler},
  {s_xt_app_create_shell,	xt_app_create_shell},
  {s_xt_create_managed_widget,	xt_create_managed_widget},
  {s_xt_create_popup_shell,	xt_create_popup_shell},
  {s_xt_create_widget,		xt_create_widget},
  {s_xt_get_value,		xt_get_value},
  {s_xt_initialize,		xt_initialize},
  {s_xt_remove_event_handler,	xt_remove_event_handler},
  {0, 0}
};

iproc xt_lsubrs[] = {
  {s_xt_main_loop,		xt_main_loop},
  {s_xt_manage_children,	xt_manage_children},
  {s_xt_set_values,		xt_set_values},
  {s_xt_unmanage_children,	xt_unmanage_children},
  {0, 0}
};

iproc xt_subr3s[] = {
  {s_xt_move_widget,		xt_move_widget},
  {0, 0}
};

iproc xt_subr2s[] = {
  {s_xt_add_time_out,		xt_add_time_out},
  {s_xt_class_subclassp,	xt_class_subclassp},
  {s_xt_popup,			xt_popup},
  {s_xt_set_sensitive,		xt_set_sensitive},
  {s_xt_subclassp,		xt_subclassp},
  {0, 0}
};

iproc xt_subr1s[] = {
  {s_xt_add_work_proc,		xt_add_work_proc},
  {s_xt_class,			xt_class},
  {s_xt_class_name,		xt_class_name},
  {s_xt_class_superclass,	xt_class_superclass},
  {s_xt_destroy_widget,		xt_destroy_widget},
  {s_xt_dispatch_event,		xt_dispatch_event},
  {s_xt_display,		xt_display},
  {s_xt_get_constraint_resource_li, xt_get_constraint_resource_list},
  {s_xt_get_resource_list,	xt_get_resource_list},
  {s_xt_is_realized,		xt_is_realized},
  {s_xt_map_widget,		xt_map_widget},
  {s_xt_name,			xt_name},
  {s_xt_parent,			xt_parent},
  {s_xt_popdown,		xt_popdown},
  {s_xt_realize_widget,		xt_realize_widget},
  {s_xt_remove_time_out,	xt_remove_time_out},
  {s_xt_remove_work_proc,	xt_remove_work_proc},
  {s_xt_superclass,		xt_superclass},
  {s_xt_unmap_widget,		xt_unmap_widget},
  {s_xt_unrealize_widget,	xt_unrealize_widget},
  {s_xt_window,			xt_window},
  {0, 0}
};

iproc xt_subr0s[] = {
  {s_xt_next_event,		xt_next_event},
  {0, 0}
};

#undef XX
#define XX(name, mark, free, equalp) TOKEN_PASTE(tc16_,name) = newsmob(&TOKEN_PASTE(smob,name));

void init_xt()
{
  loc_callbacks = &CDR(sysintern("*xt-callbacks*", EOL));
  loc_class_map = &CDR(sysintern(s_xt_widget_class_map, EOL));
  init_iprocs(xt_lsubr2s, tc7_lsubr_2);
  init_iprocs(xt_lsubrs, tc7_lsubr);
  init_iprocs(xt_subr3s, tc7_subr_3);
  init_iprocs(xt_subr2s, tc7_subr_2);
  init_iprocs(xt_subr1s, tc7_subr_1);
  init_iprocs(xt_subr0s, tc7_subr_0);
  XT_SMOBS
  xt_init_resource_types();
  xt_init_widget_classes(
    xt_widget_classes,
    XtNumber(xt_widget_classes),
    "*xt-widget-classes*");
}
