home *** CD-ROM | disk | FTP | other *** search
/ Education Sampler 1992 [NeXTSTEP] / Education_1992_Sampler.iso / Programming / Source / winterp-1.13 / src-server / w_txlations.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-10-04  |  14.4 KB  |  401 lines
  1. /* -*-C-*-
  2. ********************************************************************************
  3. *
  4. * File:         w_txlations.c
  5. * RCS:          $Header: w_txlations.c,v 1.3 91/03/14 03:14:20 mayer Exp $
  6. * Description:  Interfaces to Xtoolkit Translation Management Facilities
  7. * Author:       Niels Mayer, HPLabs
  8. * Created:      Wed Nov 22 02:08:31 1989
  9. * Modified:     Thu Oct  3 21:12:39 1991 (Niels Mayer) mayer@hplnpm
  10. * Language:     C
  11. * Package:      N/A
  12. * Status:       X11r5 contrib tape release
  13. *
  14. * WINTERP Copyright 1989, 1990, 1991 Hewlett-Packard Company (by Niels Mayer).
  15. * XLISP version 2.1, Copyright (c) 1989, by David Betz.
  16. *
  17. * Permission to use, copy, modify, distribute, and sell this software and its
  18. * documentation for any purpose is hereby granted without fee, provided that
  19. * the above copyright notice appear in all copies and that both that
  20. * copyright notice and this permission notice appear in supporting
  21. * documentation, and that the name of Hewlett-Packard and David Betz not be
  22. * used in advertising or publicity pertaining to distribution of the software
  23. * without specific, written prior permission.  Hewlett-Packard and David Betz
  24. * make no representations about the suitability of this software for any
  25. * purpose. It is provided "as is" without express or implied warranty.
  26. *
  27. * HEWLETT-PACKARD AND DAVID BETZ DISCLAIM ALL WARRANTIES WITH REGARD TO THIS
  28. * SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS,
  29. * IN NO EVENT SHALL HEWLETT-PACKARD NOR DAVID BETZ BE LIABLE FOR ANY SPECIAL,
  30. * INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
  31. * LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE
  32. * OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
  33. * PERFORMANCE OF THIS SOFTWARE.
  34. *
  35. * See ./winterp/COPYRIGHT for information on contacting the authors.
  36. * 
  37. * Please send modifications, improvements and bugfixes to mayer@hplabs.hp.com
  38. * Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x
  39. **
  40. ********************************************************************************
  41. */
  42. static char rcs_identity[] = "@(#)$Header: w_txlations.c,v 1.3 91/03/14 03:14:20 mayer Exp $";
  43.  
  44. #include <stdio.h>
  45. #include <Xm/Xm.h>        /* Xm/Xm.h only needed for "winterp.h"*/
  46. #include "winterp.h"
  47. #include "user_prefs.h"
  48. #include "xlisp/xlisp.h"
  49.  
  50. extern Widget Wcls_Get_WIDGETOBJ_Argument_Returning_Validated_WidgetID(); /* w_classes.c */
  51.  
  52. static LVAL s_ACTION_WIDGET, s_ACTION_XEVENT, s_LISP_ACTION_PROC;
  53.  
  54.  
  55. /******************************************************************************
  56.  * Actions in winterp are added through this single action proc which will call
  57.  * the lisp evaluator upon invocation of this action.
  58.  *
  59.  * A translation/accelerator table using this proc may look like
  60.  * "<EnterWindow>: Lisp(lisp-function arg1 arg2 arg3)" in which case the
  61.  * form '(lisp-function arg1 arg2 arg3)' will be passed on to the evaluator.
  62.  *
  63.  * 
  64.  * In the lexical scope of the action invocation, ACTION_WIDGET gets bound  to
  65.  * the widget causing the action, and ACTION_XEVENT gets bound to the event.
  66.  *
  67.  * BUG: I haven't found a way of escaping characters passed on to the
  68.  * translation/action table parsers to allow lisp strings or lips lists to
  69.  * be passed on to the lisp evaluator that is called by this function. Using
  70.  * the evaluator through an action proc is still useful, just don't try to pass
  71.  * in very complex lisp forms.
  72.  * 
  73.  * NOTE: the action table for winterp is set in winterp.c.
  74.  ******************************************************************************/
  75. void Wtx_Winterp_Lisp_Action_Proc(widget, event, params, num_params)
  76.      Widget widget;
  77.      XEvent *event;
  78.      String *params;
  79.      Cardinal *num_params;
  80. {
  81.   register char c;
  82.   register LVAL new_elt, last_elt;
  83.   int param_count = *num_params;
  84.   char* par;            /* points to current parameter */
  85.   LVAL sexp_stream, parsed_sexp, oldenv;
  86.   CONTEXT cntxt;
  87.   extern LVAL Wcls_WidgetID_To_WIDGETOBJ(); /* w_classes.c */
  88.   extern LVAL xlenv;
  89.  
  90.   xlstkcheck(3);
  91.   xlsave(sexp_stream);
  92.   xlsave(parsed_sexp);
  93.   xlsave(oldenv);
  94.  
  95.   sexp_stream = newustream();    /* note - stream obj has ptrs for head and tail*/
  96.   last_elt = cons(cvchar('('), NIL); /* tack on an opening paren to beginning of form*/
  97.   sethead(sexp_stream, last_elt); /* make it the head of the stream */
  98.   
  99.   /* for each character in each param, append it onto sexp_stream */
  100.   while (param_count--) {    /* while there are more parameters */
  101.     par = *params++;        /* get current parameter string and increment to next */
  102.     while (c = *par++) {    /* go through each parameter char by char turning into a stream */
  103.       new_elt = cons(cvchar(c), NIL);
  104.       rplacd(last_elt, new_elt); /* add new elt to tail of list */
  105.       last_elt = new_elt;
  106.     }
  107.     new_elt = cons(cvchar(' '), NIL); /* put spaces between each param */
  108.     rplacd(last_elt, new_elt);
  109.     last_elt = new_elt;
  110.   }
  111.   new_elt = cons(cvchar(')'), NIL); /* tack on a closing paren to end of form */  
  112.   rplacd(last_elt, new_elt);
  113.   settail(sexp_stream, new_elt); /* streams are cdr-coded -- give ptr to tail */
  114.  
  115.   /*
  116.    * Most of the rest of this procedure looks alot like xleval.c:evfun(), which
  117.    * is what the evaluator calls when a functional form is to be evaluated. The
  118.    * main difference is that instead of calling xlabind() to bind the
  119.    * formal parameter symbols of a function to their values in the new
  120.    * lexical environment frame returned by xlframe(getenv(fun)), we 
  121.    * just bind ACTION_WIDGET and ACTION_XEVENT.
  122.    */
  123.  
  124.   /* create a new environment frame */
  125.   oldenv = xlenv;
  126.   xlenv = xlframe(xlenv);
  127.  
  128.   /* lexically bind ACTION_WIDGET and ACTION_EVENT to the widget/event that caused the callback */
  129.   xlpbind(s_ACTION_WIDGET, Wcls_WidgetID_To_WIDGETOBJ(widget), xlenv);
  130.   xlpbind(s_ACTION_XEVENT, (event) ? cv_xevent(event) : NIL, xlenv);
  131.  
  132.   /* setup the implicit block */
  133.   xlbegin(&cntxt, CF_RETURN, s_LISP_ACTION_PROC);
  134.   if (setjmp(cntxt.c_jmpbuf))
  135.     { }
  136.   else
  137.     if (xlread(sexp_stream, &parsed_sexp, FALSE)) /* if didn't hit EOF during read */
  138.       xleval(parsed_sexp);    /* then evaluate it -- we ignore evaluation result */
  139.  
  140.   xlend(&cntxt);
  141.  
  142.   /* restore the environment frame */
  143.   xlenv = oldenv;
  144.      
  145.   xlpopn(3);
  146. }
  147.  
  148.  
  149. /******************************************************************************
  150.  * (XT_PARSE_TRANSLATION_TABLE <string>)
  151.  * ==> returns a node of type XT_TRANSLATIONS, which is a compiled form of the
  152.  * <string> translation table given as argument.
  153.  *
  154.  * XtTranslations XtParseTranslationTable(source)
  155.  *     String source;
  156.  *
  157.  * NOTE: the memory allocated by XtParseTranslationTable() isn't freed anywhere
  158.  * yet -- I can't find  any documentation that says you're supposed to free
  159.  * this. For now this may be a memory leak.
  160.  ******************************************************************************/
  161. LVAL Wtx_Prim_XT_PARSE_TRANSLATION_TABLE()
  162. {
  163.   XtTranslations txl;
  164.   char* source = (char*) getstring(xlgastring());
  165.   xllastarg();
  166.   
  167.   txl = XtParseTranslationTable(source);
  168.  
  169.   return ( (txl) ? cv_xttranslations(txl) : NIL );
  170. }
  171.  
  172. /******************************************************************************
  173.  * (XT_PARSE_ACCELERATOR_TABLE <string>)
  174.  * ==> returns a node of type XT_ACCELERATORS, which is a compiled form of the
  175.  * <string> accelerator table given as argument.
  176.  *
  177.  * XtAccelerators XtParseAcceleratorTable (source)
  178.  *     String   source;
  179.  *
  180.  * NOTE: the memory allocated by XtParseAcceleratorTable() isn't freed anywhere
  181.  * yet -- I can't find  any documentation that says you're supposed to free
  182.  * this. For now this may be a memory leak.
  183.  ******************************************************************************/
  184. LVAL Wtx_Prim_XT_PARSE_ACCELERATOR_TABLE()
  185. {
  186.   XtAccelerators axl;
  187.   char* source = (char*) getstring(xlgastring());
  188.   xllastarg();
  189.   
  190.   axl = XtParseAcceleratorTable(source);
  191.  
  192.   return ( (axl) ? cv_xtaccelerators(axl) : NIL );
  193. }
  194.  
  195.  
  196. /******************************************************************************
  197.  * (send <widget> :OVERRIDE_TRANSLATIONS <translations>)
  198.  * ==> returns <widget>
  199.  * 
  200.  * This method destructively merges the new <translations> into <widget>'s
  201.  * existing translations -- event sequences in <translations> that already exist
  202.  * a previous translation will override.
  203.  *
  204.  * <translations> can be a string, in which case it
  205.  * is compiled into a translation table. Otherwise, we expect a node of
  206.  * type XT_TRANSLATIONS.
  207.  *
  208.  * void XtOverrideTranslations(widget, new)
  209.  *     Widget widget;
  210.  *     XtTranslations new;
  211.  ******************************************************************************/
  212. LVAL Widget_Class_Method_OVERRIDE_TRANSLATIONS()
  213. {
  214.   LVAL self, lval_txl;
  215.   Widget widget_id;
  216.   XtTranslations txl;
  217.  
  218.   widget_id = Wcls_Get_WIDGETOBJ_Argument_Returning_Validated_WidgetID(&self);
  219.   lval_txl = xlgetarg();
  220.   xllastarg();
  221.   
  222.   if (stringp(lval_txl))
  223.     txl = XtParseTranslationTable((char*) getstring(lval_txl));
  224.   else if (xttranslations_p(lval_txl))
  225.     txl = get_xttranslations(lval_txl);
  226.   else
  227.     xlerror("Bad argument type -- expected a string or XT_TRANSLATIONS.", lval_txl);
  228.  
  229.   XtOverrideTranslations(widget_id, txl);
  230.   return (self);
  231. }
  232.  
  233. /******************************************************************************
  234.  * (send <widget> :AUGMENT_TRANSLATIONS <translations>) 
  235.  * ==> returns <widget>.
  236.  *
  237.  * This method nondestructively merges the new <translations> into <widget>'s
  238.  * existing translations -- event sequences in <translations> that already exist
  239.  * a previous translation will be ignored.
  240.  *
  241.  * <translations> can be a string, in which case it
  242.  * is compiled into a translation table. Otherwise, we expect a node of
  243.  * type XT_TRANSLATIONS.
  244.  *
  245.  * void XtAugmentTranslations(widget, new)
  246.  *     Widget widget;
  247.  *     XtTranslations new;
  248.  ******************************************************************************/
  249. LVAL Widget_Class_Method_AUGMENT_TRANSLATIONS()
  250. {
  251.   LVAL self, lval_txl;
  252.   Widget widget_id;
  253.   XtTranslations txl;
  254.  
  255.   widget_id = Wcls_Get_WIDGETOBJ_Argument_Returning_Validated_WidgetID(&self);
  256.   lval_txl = xlgetarg();
  257.   xllastarg();
  258.   
  259.   if (stringp(lval_txl))
  260.     txl = XtParseTranslationTable((char*) getstring(lval_txl));
  261.   else if (xttranslations_p(lval_txl))
  262.     txl = get_xttranslations(lval_txl);
  263.   else
  264.     xlerror("Bad argument type -- expected a string or XT_TRANSLATIONS.", lval_txl);
  265.  
  266.   XtAugmentTranslations(widget_id, txl);
  267.   return (self);
  268. }
  269.  
  270. /******************************************************************************
  271.  * (send <widget> :UNINSTALL_TRANSLATIONS)
  272.  * ==>  returns <widget>
  273.  *
  274.  * This method removes all translations from <widget>.
  275.  *
  276.  * void XtUninstallTranslations(widget)
  277.  *     Widget widget;
  278.  ******************************************************************************/
  279. LVAL Widget_Class_Method_UNINSTALL_TRANSLATIONS()
  280. {
  281.   LVAL self;
  282.   Widget widget_id;
  283.  
  284.   widget_id = Wcls_Get_WIDGETOBJ_Argument_Returning_Validated_WidgetID(&self);
  285.   xllastarg();
  286.   
  287.   XtUninstallTranslations(widget_id);
  288.   return (self);
  289. }
  290.  
  291. /******************************************************************************
  292.  * (send <destination> :INSTALL_ACCELERATORS <source>)
  293.  * ==>  returns <destination>
  294.  * 
  295.  * This method installs the accelerators from widget <source> onto widget
  296.  * <destination> by augmenting the destination translations with the source
  297.  * accelerators.
  298.  * 
  299.  * void XtInstallAccelerators(destination,source)
  300.  *     Widget destination,source;
  301.  ******************************************************************************/
  302. LVAL Widget_Class_Method_INSTALL_ACCELERATORS()
  303. {
  304.   LVAL self, lval_src;
  305.   Widget widget_id, src;
  306.  
  307.   widget_id = Wcls_Get_WIDGETOBJ_Argument_Returning_Validated_WidgetID(&self);
  308.   src = Wcls_Get_WIDGETOBJ_Argument_Returning_Validated_WidgetID(&lval_src);
  309.   xllastarg();
  310.   
  311.   XtInstallAccelerators(widget_id, src);
  312.   return (self);
  313. }
  314.  
  315.  
  316. /******************************************************************************
  317.  * (send <destination> :INSTALL_ALL_ACCELERATORS <source>)
  318.  * ==>  returns <destination>
  319.  * 
  320.  * This method installs the accelerators from widget <source> and all it's 
  321.  * children onto widget <destination> by augmenting the destination translations
  322.  * with the source accelerators.
  323.  *
  324.  * void XtInstallAllAccelerators(destination,source)
  325.  *    Widget destination,source;
  326.  ******************************************************************************/
  327. LVAL Widget_Class_Method_INSTALL_ALL_ACCELERATORS()
  328. {
  329.   LVAL self, lval_src;
  330.   Widget widget_id, src;
  331.  
  332.   widget_id = Wcls_Get_WIDGETOBJ_Argument_Returning_Validated_WidgetID(&self);
  333.   src = Wcls_Get_WIDGETOBJ_Argument_Returning_Validated_WidgetID(&lval_src);
  334.   xllastarg();
  335.   
  336.   XtInstallAllAccelerators(widget_id, src);
  337.   return (self);
  338. }
  339.  
  340.  
  341. #ifdef WINTERP_MOTIF_11
  342. /******************************************************************************
  343.  * (send <widget> :CALL_ACTION_PROC <action> <event> [<param0> [<param1> [...] ]])
  344.  * ==>  returns <widget>
  345.  * 
  346.  *
  347.  * void XtCallActionProc(Widget        -* widget *-,
  348.  *             CONST String    -* action *-,
  349.  *             XEvent*    -* event *-,
  350.  *             String*    -* params *-,
  351.  *             Cardinal    -* num_params *-);
  352.  ******************************************************************************/
  353. LVAL Widget_Class_Method_CALL_ACTION_PROC()
  354. {
  355. #define PARAMS_SIZE_INCREMENT 5
  356.   LVAL self;
  357.   Widget widget_id;
  358.   String action;
  359.   XEvent* event;
  360.   String* params;
  361.   Cardinal num_params = 0;
  362.   Cardinal params_size;
  363.  
  364.   widget_id = Wcls_Get_WIDGETOBJ_Argument_Returning_Validated_WidgetID(&self); /* get <widget> */
  365.   action = (String) getstring(xlgastring()); /* get <action> */
  366.   event = get_xevent(xlga_xevent()); /* get <xevent> */
  367.  
  368.   /* get optional  [<param0> [<param1> [...] ]] */
  369.   if (moreargs()) {
  370.     params_size = PARAMS_SIZE_INCREMENT;
  371.     params = (String*) XtMalloc((unsigned) (params_size * sizeof(String)));
  372.     while (moreargs()) {
  373.       if (num_params >= params_size) { /* make sure it'll fit into allocated table */
  374.     params_size += PARAMS_SIZE_INCREMENT;
  375.     params = (String*) XtRealloc(params, (unsigned) (params_size * sizeof(String)));
  376.       }
  377.       params[num_params++] = (String) getstring(xlgastring());
  378.     }
  379.   }
  380.   xllastarg();
  381.   
  382.   XtCallActionProc(widget_id, action, event, params, num_params);
  383.  
  384.   if (num_params)
  385.     XtFree(params);
  386.   return (self);
  387. #undef PARAMS_SIZE_INCREMENT
  388. }
  389. #endif /* WINTERP_MOTIF_11 */
  390.  
  391.  
  392. /******************************************************************************
  393.  *
  394.  ******************************************************************************/
  395. Wtx_Init()
  396. {
  397.   s_ACTION_WIDGET = xlenter("ACTION_WIDGET");
  398.   s_ACTION_XEVENT = xlenter("ACTION_XEVENT");
  399.   s_LISP_ACTION_PROC = xlenter("LISP_ACTION_PROC");
  400. }
  401.