#include "xt.h"

#define MAX_CALLBACKS   512

static Object Callbacks;

typedef struct {
    PFO converter;
    int num;
} CLIENT_DATA;

Object Get_Callbackfun (c) caddr_t c; {
    register CLIENT_DATA *cd = (CLIENT_DATA *)c;
    return cd ? VECTOR(Callbacks)->data[cd->num] : False;
}

static void Callback_Proc (w, client_data, call_data) Widget w;
	caddr_t client_data, call_data; {
    register CLIENT_DATA *cd = (CLIENT_DATA *)client_data;
    Object args;

    args = Null;
    if (cd->converter)
	args = Cons ((cd->converter)((XtArgVal)call_data), args);
    args = Cons (Make_Widget (w), args);
    (void)Funcall (Get_Callbackfun (client_data), args, 0);
}

/*ARGSUSED*/
void Destroy_Callback_Proc (w, client_data, call_data) Widget w;
	caddr_t client_data, call_data; {
    Object x;

    x = Find_Object (T_Widget, (GENERIC)0, Match_Xt_Obj, w);
    if (Nullp (x) || WIDGET(x)->free)
	return;
    WIDGET(x)->free = 1;
    Remove_All_Callbacks (w);
    Deregister_Object (x);
}

/* The code assumes that callbacks are called in the order they
 * have been added.  The Destroy_Callback_Proc() must always be
 * the last callback in the destroy callback list of each widget.
 *
 * When the destroy callback list of a widget is modified
 * (via P_Add_Callbacks or P_Set_Values), Fiddle_Destroy_Callback()
 * must be called to remove the Destroy_Callback_Proc() and put
 * it back to the end of the callback list.
 */
Fiddle_Destroy_Callback (w) Widget w; {
    XtRemoveCallback (w, XtNdestroyCallback, Destroy_Callback_Proc, (caddr_t)0);
    XtAddCallback (w, XtNdestroyCallback, Destroy_Callback_Proc, (caddr_t)0);
}

Check_Callback_List (x) Object x; {
    Object tail;

    Check_List (x);
    for (tail = x; !Nullp (tail); tail = Cdr (tail))
	Check_Procedure (Car (tail));
}

static Object P_Add_Callbacks (w, name, cbl) Object w, name, cbl; {
    register char *s;
    register n;
    XtCallbackList callbacks;

    Check_Widget (w);
    Check_Callback_List (cbl);
    Make_C_String (name, s);
    Make_Resource_Name (s);
    n = Internal_Length (cbl);
    callbacks = (XtCallbackRec *)alloca ((n+1) * sizeof (XtCallbackRec));
    callbacks[n].callback = 0;
    callbacks[n].closure = 0;
    Fill_Callbacks (cbl, callbacks, n,
	Find_Callback_Converter (XtClass (WIDGET(w)->widget), s, name));
    XtAddCallbacks (WIDGET(w)->widget, s, callbacks);
    if (streq (s, XtNdestroyCallback))
	Fiddle_Destroy_Callback (WIDGET(w)->widget);
    return Void;
}

Fill_Callbacks (src, dst, n, conv) Object src; XtCallbackList dst;
	register n; PFO conv; {
    register CLIENT_DATA *cd;
    register i, j;
    Object tail;
    GC_Node2;

    GC_Link2 (src, tail);
    for (i = 0, tail = src; i < n; i++, tail = Cdr (tail)) {
	Object fun = Car (tail);
	for (j = 0; j < MAX_CALLBACKS; j++)
	    if (Nullp (VECTOR(Callbacks)->data[j])) break;
	if (j == MAX_CALLBACKS)
	    Primitive_Error ("too many callbacks");
	VECTOR(Callbacks)->data[j] = fun;
	cd = (CLIENT_DATA *)XtMalloc (sizeof (CLIENT_DATA));
	cd->converter = conv;
	cd->num = j;
	dst[i].callback = (XtCallbackProc)Callback_Proc;
	dst[i].closure = (caddr_t)cd;
    }
    GC_Unlink;
}

static Remove_All_Callbacks (w) Widget w; {
    Arg a[1];
    XtCallbackList c;
    XtResource *r;
    int nr, nc;
    register i, j;

    Get_All_Resources (w, XtClass (w), &r, &nr, &nc);
    for (j = 0; j < nr; j++) {
	if (streq (r[j].resource_type, XtRCallback)) {
	    XtSetArg (a[0], r[j].resource_name, &c);
	    XtGetValues (w, a, ONE);
	    for (i = 0; c[i].callback; i++) {
		register CLIENT_DATA *cd = (CLIENT_DATA *)c[i].closure;
		if (c[i].callback == (XtCallbackProc)Callback_Proc && cd) {
		    VECTOR(Callbacks)->data[cd->num] = Null;
		    XtFree ((char *)cd);
		}
	    }
	}
    }
    XtFree ((char *)r);
}

init_xt_callback () {
    Callbacks = Make_Vector (MAX_CALLBACKS, Null);
    Global_GC_Link (Callbacks);
    Define_Primitive (P_Add_Callbacks, "add-callbacks", 3, 3, EVAL);
}