Return to XtAddCallback.rplc CVS log

Up to [local] / rpl / modules / motif

Annotation of rpl/modules/motif/XtAddCallback.rplc, revision 1.6

1.1       bertrand    1: #include "src/rplexternals.h"
                      2: #include "motif.h"
                      3: 
                      4: declareExternalFunction(XtAddCallback)
                      5:    declareObject(widget);
                      6:    declareObject(callbackName);
1.4       bertrand    7:    declareObject(callbackObject);
1.1       bertrand    8:    declareObject(callbackProc);
1.4       bertrand    9:    declareDaisyChain(tmp);
1.1       bertrand   10: 
1.3       bertrand   11:    sXtCallback             *sCallback;
1.1       bertrand   12: 
1.3       bertrand   13:    string                  type;
                     14: 
                     15:    String                  callback;
                     16: 
1.1       bertrand   17:    HEADER
                     18:        declareHelpString("Add callback to a widget\n"
                     19:                "    3: widget\n"
                     20:                "    2: callback name (XmNactivateCallback)\n"
1.4       bertrand   21:                "    1: expression\n"
                     22:                " -> 1: callback\n");
1.1       bertrand   23:        numberOfArguments(3);
                     24:    FUNCTION
                     25:        if (initializationDone eq true) then
                     26:            pullFromStack(callbackProc, unknown);
                     27:            returnOnError(freeObject(callbackProc));
                     28: 
                     29:            pullFromStack(callbackName, string);
                     30:            returnOnError(freeObject(callbackProc); freeObject(callbackName));
                     31: 
                     32:            pullFromStack(widget, external);
                     33:            returnOnError(freeObject(callbackProc); freeObject(callbackName);
                     34:                    freeObject(widget));
                     35: 
                     36:            ifIsExternal(widget, WIDGET) then
                     37:            orElse
                     38:                executionError("Type mismatch error");
                     39:                returnOnError(freeObject(callbackProc);
                     40:                        freeObject(callbackName); freeObject(widget));
                     41:            endIf
                     42: 
                     43:            getString(callbackName, type);
                     44: 
                     45:            if (strcmp(type, "XmNactivateCallback") eq 0) then
                     46:                callback = XmNactivateCallback;
                     47:            orElse
                     48:                executionError("Unknown callback type");
                     49:                returnOnError(freeObject(callbackProc);
                     50:                        freeObject(callbackName); freeObject(widget));
                     51:            endIf
                     52: 
1.4       bertrand   53:            createExternalObject(callbackObject, CALLBACK);
                     54: 
1.3       bertrand   55:            sCallback = allocate(size(sXtCallback));
                     56:            sCallback->status = procStatus(rpl_arguments);
                     57:            sCallback->callback = callbackProc;
1.6     ! bertrand   58:            sCallback->widget = target(objectContainer(Widget, widget));
        !            59:            objectOf(callbackObject) = sCallback;
1.1       bertrand   60: 
1.6     ! bertrand   61:            XtAddCallback(target(objectContainer(Widget, widget)),
1.3       bertrand   62:                    callback, rplCallback, (XtPointer) sCallback);
1.1       bertrand   63: 
1.5       bertrand   64:            tmp = allocate(size(daisyChain));
1.4       bertrand   65:            tmp->next = lCallbacks;
                     66:            tmp->data = callbackObject;
1.3       bertrand   67:            lCallbacks = tmp;
1.4       bertrand   68: 
1.5       bertrand   69:            dupObject(callbackObject);
1.4       bertrand   70:            pushOnStack(callbackObject);
1.1       bertrand   71:        orElse
                     72:            executionError("Application not initialized");
                     73:            returnOnError();
                     74:        endIf
                     75:    END
                     76: endExternalFunction
                     77: 
                     78: // vim: ts=4