[BACK]Return to XtAddCallback.rplc CVS log [TXT] [DIR] Up to [local] / rpl / modules / motif
File:  [local] / rpl / modules / motif / XtAddCallback.rplc
Revision 1.6: download - view: text, annotated - select for diffs - revision graph
Sun Jul 30 21:59:40 2017 UTC (7 years, 9 months ago) by bertrand
Branches: MAIN
CVS tags: rpl-4_1_35, rpl-4_1_34, rpl-4_1_33, rpl-4_1_32, rpl-4_1_31, rpl-4_1_30, rpl-4_1_29, rpl-4_1_28, rpl-4_1_27, HEAD
Ajout d'une série de patches pour gérer les instructions de type A->B
dans les bibliothèques externes.

    1: #include "src/rplexternals.h"
    2: #include "motif.h"
    3: 
    4: declareExternalFunction(XtAddCallback)
    5:     declareObject(widget);
    6:     declareObject(callbackName);
    7:     declareObject(callbackObject);
    8:     declareObject(callbackProc);
    9:     declareDaisyChain(tmp);
   10: 
   11:     sXtCallback             *sCallback;
   12: 
   13:     string                  type;
   14: 
   15:     String                  callback;
   16: 
   17:     HEADER
   18:         declareHelpString("Add callback to a widget\n"
   19:                 "    3: widget\n"
   20:                 "    2: callback name (XmNactivateCallback)\n"
   21:                 "    1: expression\n"
   22:                 " -> 1: callback\n");
   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: 
   53:             createExternalObject(callbackObject, CALLBACK);
   54: 
   55:             sCallback = allocate(size(sXtCallback));
   56:             sCallback->status = procStatus(rpl_arguments);
   57:             sCallback->callback = callbackProc;
   58:             sCallback->widget = target(objectContainer(Widget, widget));
   59:             objectOf(callbackObject) = sCallback;
   60: 
   61:             XtAddCallback(target(objectContainer(Widget, widget)),
   62:                     callback, rplCallback, (XtPointer) sCallback);
   63: 
   64:             tmp = allocate(size(daisyChain));
   65:             tmp->next = lCallbacks;
   66:             tmp->data = callbackObject;
   67:             lCallbacks = tmp;
   68: 
   69:             dupObject(callbackObject);
   70:             pushOnStack(callbackObject);
   71:         orElse
   72:             executionError("Application not initialized");
   73:             returnOnError();
   74:         endIf
   75:     END
   76: endExternalFunction
   77: 
   78: // vim: ts=4
CVSweb interface <joel.bertrand@systella.fr>