#include "xt.h"

#define MAX_WORKPROCS            512
#define MAX_TIMEOUTS             512

static Object Workprocs, Timeouts;

static SYMDESCR XtIM_Syms[] = {
    { "x-event",         XtIMXEvent },
    { "timer",           XtIMTimer },
    { "alternate-input", XtIMAlternateInput },
    { 0, 0 }
};

static Object P_Destroy_Context();

Generic_Predicate (Context);

Generic_Equal (Context, CONTEXT, context);

Generic_Print (Context, "#[context %u]", POINTER(x));

Object Make_Context (context) XtAppContext context; {
    register char *p;
    Object c;

    c = Find_Object (T_Context, (GENERIC)0, Match_Xt_Obj, context);
    if (Nullp (c)) {
	p = Get_Bytes (sizeof (struct S_Context));
	SET (c, T_Context, (struct S_Context *)p);
	CONTEXT(c)->tag = Null;
	CONTEXT(c)->context = context;
	CONTEXT(c)->free = 0;
	Register_Object (c, (GENERIC)0, P_Destroy_Context, 0);
	XtAppSetWarningHandler (context, Xt_Warning);
    }
    return c;
}

static Check_Context (c) Object c; {
    Check_Type (c, T_Context);
    if (CONTEXT(c)->free)
	Primitive_Error ("invalid context: ~s", c);
}

static Object P_Create_Context () {
    /*  Should read:
    return Make_Context (XtCreateApplicationContext ());
     *  but Xt is broken (timers are added to the wrong context).
     */
    extern XtAppContext _XtDefaultAppContext();
    return Make_Context (_XtDefaultAppContext ());
}

static Object P_Destroy_Context (c) Object c; {
    Check_Context (c);
    XtDestroyApplicationContext (CONTEXT(c)->context);
    CONTEXT(c)->free = 1;
    Deregister_Object (c);
    return Void;
}

static Object P_Initialize_Display (c, d, name, class)
	Object c, d, name, class; {
    register char *sn, *sc, *sd = 0;
    register t = TYPE(d);
    Display *dpy;
    extern char **Argv;
    extern First_Arg, Argc;
    int argc = Argc - First_Arg + 1;

    Argv[First_Arg-1] = "bogus";  /* Not actually used by Xt.  Or is it? */
    Check_Context (c);
    Make_C_String (name, sn);
    Make_C_String (class, sc);
    if (t == T_Display) {
	XtDisplayInitialize (CONTEXT(c)->context, DISPLAY(d)->dpy,
	    sn, sc, (XrmOptionDescRec *)0, 0, &argc, &Argv[First_Arg-1]);
	Argc = First_Arg + argc;
	return Void;
    }
    if (Truep (d))
	Make_C_String (d, sd);
    dpy = XtOpenDisplay (CONTEXT(c)->context, sd, sn, sc,
	(XrmOptionDescRec *)0, 0, &argc, &Argv[First_Arg-1]);
    Argc = First_Arg + argc - 1;
    if (dpy == 0)
	if (sd)
	    Primitive_Error ("cannot open display ~s", d);
	else
	    Primitive_Error ("cannot open display");
    return Make_Display (0, dpy);
}

static Object P_Context_Main_Loop (c) Object c; {
    Check_Context (c);
    XtAppMainLoop (CONTEXT(c)->context);
    /*NOTREACHED*/
}

static Object P_Context_Pending (c) Object c; {
    Check_Context (c);
    return Bits_To_Symbols ((unsigned long)XtAppPending (CONTEXT(c)->context),
	1, XtIM_Syms);
}

static Object P_Context_Process_Event (argc, argv) Object *argv; {
    XtInputMask mask = XtIMAll;

    Check_Context (argv[0]);
    if (argc == 2)
	mask = (XtInputMask)Symbols_To_Bits (argv[1], 1, XtIM_Syms);
    XtAppProcessEvent (CONTEXT(argv[0])->context, mask);
    return Void;
}

static Work_Proc (client_data) caddr_t client_data; {
    Object ret = Funcall (VECTOR(Workprocs)->data[(int)client_data], Null, 0);
    if (Truep (ret))
	VECTOR(Workprocs)->data[(int)client_data] = Null;
    return Truep (ret);
}

static Object P_Context_Add_Work_Proc (c, p) Object c, p; {
    XtWorkProcId id;
    register i;

    Check_Context (c);
    Check_Procedure (p);
    for (i = 0; i < MAX_WORKPROCS; i++)
	if (Nullp (VECTOR(Workprocs)->data[i])) break;
    if (i == MAX_WORKPROCS)
	Primitive_Error ("too many work procs");
    VECTOR(Workprocs)->data[i] = p;
    id = XtAppAddWorkProc (CONTEXT(c)->context, Work_Proc, (caddr_t)i);
    return Make_Id ('w', (caddr_t)id, i);
}

static Object P_Remove_Work_Proc (id) Object id; {
    XtRemoveWorkProc ((XtWorkProcId)Use_Id (id, 'w'));
    VECTOR(Workprocs)->data[IDENTIFIER(id)->num] = Null;
    return Void;
}

static Timeout_Proc (client_data, id) caddr_t client_data; XtIntervalId *id; {
    Object proc, args;

    args = Cons (Make_Id ('t', (caddr_t)*id, 0), Null);
    proc = VECTOR(Timeouts)->data[(int)client_data];
    VECTOR(Timeouts)->data[(int)client_data] = Null;
    (void)Funcall (proc, args, 0);
}

static Object P_Context_Add_Timeout (c, n, p) Object c, n, p; {
    XtIntervalId id;
    register i;

    Check_Context (c);
    Check_Procedure (p);
    for (i = 0; i < MAX_TIMEOUTS; i++)
	if (Nullp (VECTOR(Timeouts)->data[i])) break;
    if (i == MAX_TIMEOUTS)
	Primitive_Error ("too many timeouts");
    VECTOR(Timeouts)->data[i] = p;
    id = XtAppAddTimeOut (CONTEXT(c)->context, Get_Integer (n), Timeout_Proc,
	(caddr_t)i);
    return Make_Id ('t', (caddr_t)id, i);
}

static Object P_Remove_Timeout (id) Object id; {
    XtRemoveTimeOut ((XtIntervalId)Use_Id (id, 't'));
    VECTOR(Timeouts)->data[IDENTIFIER(id)->num] = Null;
    return Void;
}

init_xt_context () {
    Workprocs = Make_Vector (MAX_WORKPROCS, Null);
    Global_GC_Link (Workprocs);
    Timeouts = Make_Vector (MAX_TIMEOUTS, Null);
    Global_GC_Link (Timeouts);
    Generic_Define (Context, "context", "context?");
    Define_Primitive (P_Create_Context,     "create-context",     0, 0, EVAL);
    Define_Primitive (P_Destroy_Context,    "destroy-context",    1, 1, EVAL);
    Define_Primitive (P_Initialize_Display, "initialize-display", 4, 4, EVAL);
    Define_Primitive (P_Context_Main_Loop,  "context-main-loop",  1, 1, EVAL);
    Define_Primitive (P_Context_Pending,    "context-pending",    1, 1, EVAL);
    Define_Primitive (P_Context_Process_Event, "context-process-event",
							      1, 2, VARARGS);
    Define_Primitive (P_Context_Add_Work_Proc, "context-add-work-proc",
							      2, 2, EVAL);
    Define_Primitive (P_Remove_Work_Proc,   "remove-work-proc",   1, 1, EVAL);
    Define_Primitive (P_Context_Add_Timeout,"context-add-timeout",3, 3, EVAL);
    Define_Primitive (P_Remove_Timeout,     "remove-timeout",     1, 1, EVAL);
    XtToolkitInitialize ();
    P_Provide (Intern ("xt.o"));
}