home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / swat / c / tk-c.c < prev    next >
C/C++ Source or Header  |  1995-08-02  |  10KB  |  309 lines
  1. /* -*- C -*-
  2. /* tk-c.c - Support routines for Tk Widgets called from Scheme */
  3. /* $Id: tk-c.c,v 1.1 1995/08/02 21:21:00 adams Exp $ */
  4.  
  5. /**********************************************************************
  6.  This file contains the C code shared between MIT CScheme and DEC
  7.  Scheme-To-C for interfacing to general TK things.   There are similar
  8.  files for particular widgets, named things like "button-c.c".  The
  9.  Scheme implementation specific interface files for this are tk-sc.sc,
  10.  tk-c-mit.c, and tk-mit.scm.
  11. **********************************************************************/
  12.  
  13. #include "tk.h"
  14. #include  <tcl/tclInt.h>
  15. #include  <tclHash.h>
  16.  
  17. /* structure for passing callbacks to the TK Shell */
  18.  
  19. typedef    struct {
  20.     char    *name;  /* Name of command       */
  21.     Tcl_CmdProc *proc;  /* Pointer to procedure  */
  22.     ClientData  data;   /* Client data           */
  23. } TKCallbacks, *TKCallbackPtr;
  24.  
  25. /* shell procedure declaration */
  26.  
  27. static void    TKShell
  28. (
  29.  Tk_Window,         /* Application main window */
  30.  char *,        /* Name of shell window    */
  31.  char *,        /* Class name              */
  32.  TKCallbackPtr        /* Array of callbacks      */
  33. );
  34.  
  35. /* This procedure is registered with TCL under the name
  36.    "SchemeCallBack".  TK widgets are given command lines of the form
  37.    "-command SchemeCallBack n" where "n" is the object ID of the
  38.    Scheme call back procedure.  Thus, when TK actually calls this
  39.    procedure, it will pass as argv[1] the Scheme object ID (as a
  40.    string), followed by any TK-supplied arguments.
  41.  
  42.    This procedure side-effects the C global variable TK_CallBack_List
  43.    (in file tk-c-mit.c).  The value of this variable is tested in
  44.    %tkOwnsEvent? to generate callbacks int Scheme.
  45.  
  46.    Tk_SchemeCallBack COPIES all of the arguments passed in, since I
  47.    haven't the vaguest idea how TK handles garbage collection.
  48. */
  49.  
  50. static int NDigits(unsigned long N)
  51. { register Ans = 1;
  52.   while (N > 9)
  53.   { Ans += 1;
  54.     N = N/10;
  55.   }
  56.   return Ans;
  57. }
  58.  
  59. #define TK_CALLBACK_CHUNK_SIZE    256
  60. static long Size_Of_TK_Callbacks = 0;
  61.  
  62. void Allocate_TK_Callback(long NChars)
  63. { /* Size_Of_TK_Callbacks will always be a multiple of              */
  64.   /* TK_CALLBACK_CHUNK_SIZE.  It is the total number of bytes       */
  65.   /* available, and includes space for the terminating null.        */
  66.   /* NChars_In_TK_Callbacks, however, is the number of useful bytes */
  67.   /* and does NOT include the terminating null byte.  NChars is the */
  68.   /* number of bytes to be added to the current contents.           */
  69.  
  70.   extern char *TK_CallBack_List;
  71.   extern long NChars_In_TK_Callbacks;
  72.  
  73.   Size_Of_TK_Callbacks = 
  74.     (((NChars_In_TK_Callbacks+NChars)/TK_CALLBACK_CHUNK_SIZE)+1) *
  75.       TK_CALLBACK_CHUNK_SIZE;
  76.   if (NChars_In_TK_Callbacks == 0)
  77.     TK_CallBack_List = malloc(Size_Of_TK_Callbacks);
  78.   else
  79.     TK_CallBack_List =
  80.       (char *) realloc(TK_CallBack_List, Size_Of_TK_Callbacks);
  81.   return;
  82. }
  83.     
  84. extern void AddSchemeCallBack(int argc, char **argv, long *countv)
  85. { /* argc is the number of arguments to be transmitted.  They start at */
  86.   /* argv[0].  This isn't the usual C convention, but it is more       */
  87.   /* sensible.                                                         */
  88.   extern char *TK_CallBack_List;
  89.   extern long NChars_In_TK_Callbacks;
  90.   register long ThisEntryLength = 0;
  91.   register long i;
  92.   register char **This;
  93.   register long *Count;
  94.   char *NextEntry;
  95.   long NChars_To_Add;
  96.  
  97.   /* First, calculate how much space we need */
  98.   for (i=0, Count=countv; i < argc; i++)
  99.   { register long N = *Count++;
  100.     ThisEntryLength += N + 2 + NDigits(N); /* 2 for < > */
  101.   }
  102.   NChars_To_Add =
  103.     ThisEntryLength + 2 + NDigits(ThisEntryLength); /* 2 more for < > */
  104.   if ((NChars_In_TK_Callbacks+NChars_To_Add+1) > Size_Of_TK_Callbacks)
  105.     Allocate_TK_Callback(NChars_To_Add);
  106.   NextEntry = &(TK_CallBack_List[NChars_In_TK_Callbacks]);
  107.   NChars_In_TK_Callbacks += NChars_To_Add;
  108.   /* And start putting in the information */
  109.   NextEntry += sprintf(NextEntry, "<%d>", ThisEntryLength);
  110.   for (i=0, This=argv, Count=countv; i < argc; i++, This++, Count++)
  111.   { NextEntry += sprintf(NextEntry, "<%d>", *Count);
  112.     memcpy(NextEntry, *This, *Count);
  113.     NextEntry += *Count;
  114.   }
  115.   if (NextEntry != TK_CallBack_List+(NChars_In_TK_Callbacks))
  116.     fprintf(stderr, "Tk_SchemeCallback %d %s\n",
  117.         NChars_In_TK_Callbacks, TK_CallBack_List);
  118.   *NextEntry = '\0';        /* Null terminate the string */
  119.   return;
  120. }
  121.  
  122. int
  123. Tk_TkError(ClientData clientData,
  124.        Tcl_Interp *interp,
  125.        int argc,
  126.        char **argv)
  127. { if (argc==2)
  128.   { fprintf(stderr, "TCL Error: %s\n", argv[1]);
  129.     fputs(Tcl_GetVar(interp, "errorInfo", 0), stderr);
  130.   }
  131.   else
  132.     fprintf(stderr, "TCL Error with argc=%d!\n", argc);
  133.   error_external_return();
  134. }
  135.  
  136. int
  137. Tk_SchemeCallBack(clientData, interp, argc, argv)
  138.     ClientData clientData;    /* Main window associated with
  139.                  * interpreter. NOT USED. */
  140.     Tcl_Interp *interp;        /* Current interpreter. NOT USED. */
  141.     int argc;            /* Number of arguments. */
  142.     char **argv;        /* Argument strings. */
  143. { /* As usual, argv[0] is *NOT* used for anything! */
  144.   long *Counts = (long *) malloc(argc*sizeof(long));
  145.   register long i, *Count;
  146.   register char **This;
  147.  
  148.   if (Counts == NULL)
  149.   { fprintf(stderr, "Out of space in Tk_SchemeCallBack\n");
  150.     exit (1);
  151.   }
  152.   for (i=1, This=argv+1, Count=Counts+1; i < argc; i++)
  153.     *Count++ = strlen(*This++);
  154.   AddSchemeCallBack(argc-1, argv+1, Counts+1);
  155.   /* Deliberately not changing interp->result, 'cause the TCL manual */
  156.   /* says we don't have to if we don't want to.                      */
  157.   return TCL_OK;
  158. }
  159.  
  160. /*
  161.  * External Interface Routines
  162.  */
  163.  
  164. int Scheme_TK_X_error_handler(ClientData D, XErrorEvent *E)
  165. { extern void Scheme_x_error_handler(Display *Disp, XErrorEvent *Event);
  166.  
  167.   fprintf(stderr, "Our Handler for %d 0x%x\n", D, E);
  168.   Scheme_x_error_handler((Display *) D, E);
  169.   return 0;
  170. }
  171.  
  172. extern Tk_Window
  173. InitTkApplication(Display *Disp, char *Name)
  174. { Tk_Window Result;
  175.   extern Tk_Window
  176.     Tk_CreateMainWindow_from_display(Tcl_Interp *interp,
  177.                      Display *display,
  178.                      char *baseName);
  179.   Tcl_Interp *tclInterp = Tcl_CreateInterp();
  180. /*
  181.   static char initTCLCmd[] =
  182.     "source /scheme/users/jmiller/uitk/tk/tcl/library/init.tcl;";
  183.   static char initTKCmd[] =
  184.     "source /scheme/users/jmiller/uitk/tk/library/tk.tcl";
  185.   static char initEmacsCmd[] =
  186.     "source /scheme/users/jmiller/uitk/tk/library/emacs.tcl";
  187. */
  188.  
  189.   static char initTCLCmd[] =   "source [info library]/init.tcl;";
  190.   static char initTKCmd[] =    "source $tk_library/tk.tcl";
  191.   static char initEmacsCmd[] = "source $tk_library/emacs.tcl";
  192.     
  193.   Result = Tk_CreateMainWindow_from_display(tclInterp, Disp, Name);
  194.   if (Result == (Tk_Window) NULL)
  195.     fprintf(stderr,
  196.         "Error from Tk_CreateMainWindow: %s\n"
  197.         , tclInterp->result);
  198.   if (Tcl_Eval(tclInterp, initTCLCmd, 0, (char **) NULL) != TCL_OK)
  199.   { char * msg = Tcl_GetVar(tclInterp, "errorInfo", TCL_GLOBAL_ONLY);
  200.     if (msg == NULL) msg = tclInterp->result;
  201.     fprintf(stderr, "%s\n", msg);
  202.     return (Tk_Window) NULL;
  203.   }
  204.   /* This must be read for EVERY new main window, since it     */
  205.   /* establishes bindings and so forth that use "." implicitly */
  206.   if (Tcl_Eval(tclInterp, initTKCmd, 0, (char **) NULL) != TCL_OK)
  207.   { char * msg = Tcl_GetVar(tclInterp, "errorInfo", TCL_GLOBAL_ONLY);
  208.     if (msg == NULL) msg = tclInterp->result;
  209.     fprintf(stderr, "%s\n", msg);
  210.     return (Tk_Window) NULL;
  211.   }
  212.   if (Tcl_Eval(tclInterp, initEmacsCmd, 0, (char **) NULL) != TCL_OK)
  213.   { char * msg = Tcl_GetVar(tclInterp, "errorInfo", TCL_GLOBAL_ONLY);
  214.     if (msg == NULL) msg = tclInterp->result;
  215.     fprintf(stderr, "%s\n", msg);
  216.     return (Tk_Window) NULL;
  217.   }
  218.   Tcl_CreateCommand(tclInterp,
  219.             "SchemeCallBack",
  220.             Tk_SchemeCallBack,
  221.             (ClientData) 0 /* not used */,
  222.             (void (*)()) NULL);    /* Delete Procedure */
  223.   Tcl_CreateCommand(tclInterp,
  224.             "tkerror",
  225.             Tk_TkError,
  226.             (ClientData) 0 /* not used */,
  227.             (void (*) ()) NULL); /* Delete Procedure */
  228.   Tk_CreateErrorHandler(Disp, -1, -1, -1,
  229.             Scheme_TK_X_error_handler, (ClientData) Disp);
  230.   return Result;
  231. }
  232.  
  233. /*
  234.  * Process all pending Tk events, then return
  235.  */
  236.  
  237. void
  238. DoTkEvents ()
  239. { while (Tk_DoOneEvent (TK_DONT_WAIT|TK_TIMER_EVENTS|TK_IDLE_EVENTS) > 0)
  240.   { /* fprintf(stderr, "Did TK Event"); */ }
  241. }
  242.  
  243. /*  Access the Client Data for a command.  For widget commands,
  244.  *  this is a pointer to the widget data structure.
  245.  */
  246.  
  247. ClientData
  248. GetCmdClientData (Tcl_Interp *interp, char *cmd)
  249.  
  250. {
  251.     Tcl_HashEntry   *hPtr;
  252.  
  253.     hPtr = Tcl_FindHashEntry (&((Interp *)interp)->commandTable, cmd);
  254.     return ((Command *) Tcl_GetHashValue (hPtr))->clientData;
  255. }
  256.  
  257. /*  Window structure routines.
  258.  *  These are Macros, so need a functional interface for Scheme
  259.  */
  260.  
  261. Display *
  262. tk_display (Tk_Window tkwin)
  263.  
  264. {
  265.     return Tk_Display (tkwin);
  266. }
  267.  
  268. Window
  269. tk_windowid (Tk_Window tkwin)
  270.  
  271. {
  272.     return Tk_WindowId (tkwin);
  273. }
  274.  
  275. int
  276. tk_width (Tk_Window tkwin)
  277.  
  278. {
  279.     return Tk_Width (tkwin);
  280. }
  281.  
  282. int
  283. tk_height (Tk_Window tkwin)
  284.  
  285. {
  286.     return Tk_Height (tkwin);
  287. }
  288.  
  289. void
  290. tk_set_width (Tk_Window tkwin, long W)
  291. { Tk_Width(tkwin) = W;
  292. }
  293.  
  294. void
  295. tk_set_height (Tk_Window tkwin, long H)
  296. { Tk_Height(tkwin) = H;
  297. }
  298.  
  299. /*****************************************************************/
  300. /* The following procedures OUGHT to be here, but they require   */
  301. /* internal data structure from tkButton.c to work               */
  302. /*                                                               */
  303. /* void                                                          */
  304. /* tk_map_widget (Button *button, Tk_Window tkMainWindow,        */
  305. /*                char *name, Window xwindow, int x, int y)      */
  306. /* Tk_Window                                                     */
  307. /* tk_tkwin_widget (Button *button)                              */
  308. /*****************************************************************/
  309.