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-mit.c < prev    next >
C/C++ Source or Header  |  1995-08-02  |  14KB  |  411 lines
  1. /* -*- C -*-
  2. /* Uses tk-c.c - Support routines for Tk Widgets called from Scheme */
  3. /* $Id: tk-c-mit.c,v 1.1 1995/08/02 21:21:00 adams Exp $ */
  4.  
  5. #include "scheme.h"
  6. #include "prims.h"
  7. #include "ansidecl.h"
  8. #include "X11/Xlib.h"
  9. #include "tk.h"
  10. #include "tkInt.h"        /* For TkWindow */
  11.  
  12. DEFINE_PRIMITIVE ("%tclGlobalEval", Prim_tcl_eval, 2, 2, 0)
  13. { /* (%tclGlobalEval TK-main-window string) */
  14.   Tcl_Interp *tclInterp;
  15.  
  16.   PRIMITIVE_HEADER(2);
  17.   tclInterp = (((TkWindow *) arg_integer(1))->mainPtr)->interp;
  18.   if (Tcl_GlobalEval(tclInterp, STRING_ARG(2)) != TCL_OK)
  19.   { fprintf(stderr, "%tclGlobalEval: error '%s'\n",
  20.         tclInterp->result);
  21.     error_external_return();
  22.   }
  23.   PRIMITIVE_RETURN (char_pointer_to_string
  24.             ((unsigned char *) tclInterp->result));
  25. }
  26.  
  27. long TKEvent = true;
  28. DEFINE_PRIMITIVE ("%tkCompletelyHandlesEvent?",
  29.           Prim_tk_completely_handles_event, 1, 1, 0)
  30. { /* (%tkCompletelyHandlesEvent? event) */
  31.   XEvent *Event;
  32.  
  33.   PRIMITIVE_HEADER (1);
  34.  
  35.   /*  We return 0 if there is a bad argument rather than generating  */
  36.   /* and error.  This avoids the need to put a                       */
  37.   /*  dynamic wind around calls to this primitive.                   */
  38.   /*  Error checking is                                              */
  39.   /*  done at the next level up, in tk-completely-handles-event?     */
  40.  
  41.   if (!STRING_P(ARG_REF(1))) PRIMITIVE_RETURN(LONG_TO_UNSIGNED_FIXNUM(0));
  42.   if (STRING_LENGTH(ARG_REF(1)) < sizeof(XEvent)) 
  43.            PRIMITIVE_RETURN(LONG_TO_UNSIGNED_FIXNUM(0));
  44.  
  45.  
  46.   Event = (XEvent *) STRING_ARG(1);
  47.   TKEvent = true;
  48.   Tk_HandleEvent(Event);
  49.   PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT(TKEvent));
  50. }
  51.  
  52. void OurTopLevelGeometryProc(ClientData CallBackHash, XEvent *Event)
  53. { /* Based on the code for PackStructureProc in tkPack.c.  That code */
  54.   /* handles four kinds of events: ConfigureNotify, DestroyNotify,   */
  55.   /* MapNotify, and UnmapNotify.  Here, we consider only the         */
  56.   /* ConfigureNotify case and reflect it back into Scheme.           */
  57.  
  58.   if (Event->type == ConfigureNotify)
  59.   { 
  60. #include <string.h>
  61.     extern void
  62.       AddSchemeCallBack(int argc, char **argv, long *countv);
  63.     char *argv[2], CallBackNumber[50],
  64.          EventChars[1+sizeof(XConfigureEvent)];
  65.     long Counts[2];
  66.  
  67.     XConfigureEvent *E = (XConfigureEvent *) Event;
  68.     Counts[0] = sprintf(CallBackNumber, "%d", (long) CallBackHash);
  69.     argv[0] = CallBackNumber;
  70.     Counts[1] = sizeof(XConfigureEvent);
  71.     argv[1] = (char *) E;
  72.     AddSchemeCallBack(2, argv, Counts);
  73.   }
  74. }
  75.  
  76. DEFINE_PRIMITIVE ("%tkCreateTopLevelWindow", Prim_tk_create_tl_window,
  77.           3, 3, 0)
  78. { /* (%tkCreateTopLevelWindow MainWindow Name CallBackHash) */
  79.   Tk_Window Result;
  80.   Tcl_Interp *tclInterp;
  81.   
  82.   PRIMITIVE_HEADER (3);
  83.   tclInterp = (((TkWindow *) arg_integer(1))->mainPtr)->interp;
  84.   Result =
  85.     Tk_CreateWindow(tclInterp, (Tk_Window) arg_integer(1),
  86.             STRING_ARG(2), "");
  87.   if (Result == NULL)
  88.   { fprintf(stderr, "%tkCreateTopLevelWindow: error '%s'\n",
  89.         tclInterp->result);
  90.     error_external_return();
  91.   }
  92.   Tk_SetWindowBackground(Result,
  93.              BlackPixelOfScreen(Tk_Screen(Result)));
  94.   Tk_CreateEventHandler(Result,
  95.             StructureNotifyMask,
  96.             OurTopLevelGeometryProc,
  97.             (ClientData) arg_integer(3));
  98.   PRIMITIVE_RETURN (long_to_integer((long) Result));
  99. }
  100.  
  101. char *TK_CallBack_List;
  102. long NChars_In_TK_Callbacks = 0;
  103.  
  104. DEFINE_PRIMITIVE ("%tkDoEvents", Prim_tk_do_events, 0, 0, 0)
  105. { /* (%tkDoEvents) */
  106.   extern void DoTkEvents ();
  107.   PRIMITIVE_HEADER (0);
  108.   DoTkEvents();
  109.   PRIMITIVE_RETURN (UNSPECIFIC);
  110. }
  111.  
  112. DEFINE_PRIMITIVE ("%tkDrainCallBacks", Prim_tk_drain, 2, 2, 0)
  113. { /* (%tkDrainCallBacks nchar string)                                */
  114.   /* Returns the number of characters available in the call back     */
  115.   /* string if there is NOT enough room in the string to hold all of */
  116.   /* the characters.  Otherwise, the characters are written into     */
  117.   /* STRING, C variable is cleared, space freed and the primitive    */
  118.   /* returns #F.                                                     */
  119.  
  120.   long NCharsInString;
  121.   unsigned char *StringSpace;
  122.  
  123.   PRIMITIVE_HEADER (2);
  124.   NCharsInString = arg_integer(1);
  125.   StringSpace = (unsigned char *) STRING_ARG(2);
  126.   if ((NChars_In_TK_Callbacks != 0) &&
  127.       (NCharsInString >= NChars_In_TK_Callbacks))
  128.   { fast unsigned char * scan_result = StringSpace;
  129.     fast unsigned char * end_result = (scan_result + NChars_In_TK_Callbacks);
  130.     fast unsigned char * data = (unsigned char *) TK_CallBack_List;
  131.     while (scan_result < end_result)
  132.       (*scan_result++) = (*data++);
  133.     SET_STRING_LENGTH (ARG_REF(2), NChars_In_TK_Callbacks);
  134.     /* free(TK_CallBack_List); */
  135.     /* TK_CallBack_List = NULL; */
  136.     NChars_In_TK_Callbacks = 0;
  137.     PRIMITIVE_RETURN (SHARP_F);
  138.   }
  139.   else
  140.   { PRIMITIVE_RETURN(long_to_integer(NChars_In_TK_Callbacks));
  141.   }
  142. }
  143.  
  144. void OurEventHandler(ClientData ignored_data, XEvent *ignored_event)
  145. { TKEvent = false;
  146. }
  147.  
  148. DEFINE_PRIMITIVE ("%tkGenerateSchemeEvent",
  149.           Prim_tk_generate_scheme_event, 2, 2, 0)
  150. { /* (%tkGenerateSchemeEvent mask TkWindow) */
  151.   PRIMITIVE_HEADER (2);
  152.   if (arg_integer(1) == 0)
  153.     Tk_DeleteEventHandler((Tk_Window) arg_integer(2),
  154.               arg_integer(1),
  155.               OurEventHandler,
  156.               (ClientData) 0);
  157.   else Tk_CreateEventHandler((Tk_Window) arg_integer(2),
  158.                  arg_integer(1),
  159.                  OurEventHandler,
  160.                  (ClientData) 0);
  161.   PRIMITIVE_RETURN (UNSPECIFIC);
  162. }
  163.  
  164. DEFINE_PRIMITIVE ("%tkInit", Prim_tk_init, 2, 2, 0)
  165. { /* (%tkInit display name) */
  166.   extern long /*Tk_Window*/ InitTkApplication (long /*Display*/ *display,
  167.                            char *Name);
  168.   PRIMITIVE_HEADER (2);
  169.   PRIMITIVE_RETURN((long_to_integer
  170.             ((long) InitTkApplication
  171.              ((long /*Display*/ *) arg_integer(1),
  172.               STRING_ARG(2)))));
  173. }
  174.  
  175. typedef int (*cmdProc) (ClientData clientData, Tcl_Interp *interp,
  176.             int argc, char **argv);
  177.  
  178. #define NTKCommands 14
  179. cmdProc TkCommandTable[] =
  180. { Tk_AfterCmd, Tk_BindCmd, Tk_DestroyCmd, Tk_FocusCmd, Tk_GrabCmd,
  181.   Tk_OptionCmd, Tk_PackCmd, Tk_PlaceCmd, Tk_SelectionCmd,
  182.   Tk_TkCmd, Tk_TkwaitCmd, Tk_UpdateCmd, Tk_WinfoCmd, Tk_WmCmd
  183. };
  184.  
  185. DEFINE_PRIMITIVE ("%tkInvokeCommand", Prim_tk_invoke, 2, LEXPR, 0)
  186. { /* (%tkInvokeCommand commandnumber tkmainwindow . argstrings) */
  187. #include "tkInt.h"
  188.   long WhichCommand, NArgsToPass, i, Result;
  189.   char **Argv;
  190.   SCHEME_OBJECT SchemeResult;
  191.   Tcl_Interp *tclInterp;
  192.  
  193.   PRIMITIVE_HEADER(LEXPR);
  194.   WhichCommand = arg_integer(1);
  195.   tclInterp = (((TkWindow *) arg_integer(2))->mainPtr)->interp;
  196.   if (WhichCommand > NTKCommands) error_bad_range_arg(1);
  197.   NArgsToPass = LEXPR_N_ARGUMENTS() - 1;
  198.   Argv = (char **) malloc((sizeof (char *)) * NArgsToPass);
  199.   Argv[0] = "<InvokedFromScheme>";
  200.   for (i=1; i < NArgsToPass; i++) Argv[i] = STRING_ARG(i+2);
  201.   Result = (TkCommandTable[WhichCommand])((ClientData) arg_integer(2),
  202.                       tclInterp,
  203.                       NArgsToPass,
  204.                       Argv);
  205.   free(Argv);
  206.   if (Result != TCL_OK)
  207.   { fprintf(stderr, "tkInvokeCommand error: %s\n", tclInterp->result);
  208.     error_external_return();
  209.   }
  210.   
  211.   SchemeResult = (char_pointer_to_string
  212.           ((unsigned char *) tclInterp->result));
  213.   Tcl_ResetResult(tclInterp);
  214.   PRIMITIVE_RETURN(SchemeResult);
  215. }
  216.  
  217. DEFINE_PRIMITIVE ("%tkKillApplication", Prim_tk_kill_app, 1, 1, 0)
  218. { /* (%tkKillApplication TKMainWindow) */
  219.   Tk_Window TKWin;
  220.   Tcl_Interp *Interp;
  221.   
  222.   PRIMITIVE_HEADER (1);
  223.   TKWin = (Tk_Window) arg_integer(1);
  224.   Interp = (((TkWindow *) TKWin)->mainPtr)->interp;
  225.   Tk_DestroyWindow(TKWin);
  226.   Tcl_DeleteInterp(Interp);
  227.   PRIMITIVE_RETURN (UNSPECIFIC);
  228. }
  229.  
  230. void Our_Geometry_Manager(ClientData clientData, Tk_Window tkwin)
  231. { extern void AddSchemeCallBack(int argc, char **argv, long *countv);
  232.   char *argv[1], CallBackNumber[50];
  233.   long counts[1];
  234.  
  235.   counts[0] = sprintf(CallBackNumber, "%d", (long) clientData);
  236.   argv[0] = CallBackNumber;
  237.   AddSchemeCallBack(1, argv, counts);
  238. }
  239.  
  240. DEFINE_PRIMITIVE ("%tkManageGeometry", Prim_tk_manage_geom, 2, 2, 0)
  241. { /* (%tkManageGeometry tkwin object-hash) */
  242.   PRIMITIVE_HEADER (2);
  243.   if (ARG_REF(2) == SHARP_F)
  244.     Tk_ManageGeometry((Tk_Window) arg_integer(1), NULL, 0);
  245.   else Tk_ManageGeometry((Tk_Window) arg_integer(1),
  246.              Our_Geometry_Manager,
  247.              (ClientData) arg_integer(2));
  248.   PRIMITIVE_RETURN (UNSPECIFIC);
  249. }
  250.  
  251. DEFINE_PRIMITIVE ("%tkMapWidget", Prim_tk_map_widget, 6, 6, 0)
  252. { extern char * tk_map_widget (long /*Button*/ *button,
  253.                    long /*Tk_Window*/ tkMainWindow,
  254.                    char *name,
  255.                    long /*Window*/ xwindow,
  256.                    int x, int y);
  257.   PRIMITIVE_HEADER(6);
  258.   PRIMITIVE_RETURN(char_pointer_to_string
  259.            ((unsigned char *)
  260.             tk_map_widget((long /*Button*/ *) arg_integer(1),
  261.                   (long /*Tk_Window*/) arg_integer(2),
  262.                   STRING_ARG(3),
  263.                   (long /*Window*/) arg_integer(4),
  264.                   arg_integer(5),
  265.                   arg_integer(6))));
  266.  
  267. }
  268.  
  269. DEFINE_PRIMITIVE ("%tkMapWindow", Prim_tk_map_window, 1, 1, 0)
  270. { /* (%tkMapWindow TkWindow) returns X Window ID */
  271.   Tk_Window tkwin;
  272.  
  273.   PRIMITIVE_HEADER(1);
  274.   tkwin = (Tk_Window) arg_integer(1);
  275.   Tk_MapWindow(tkwin);
  276.   PRIMITIVE_RETURN(long_to_integer((long) Tk_WindowId(tkwin)));
  277. }
  278.  
  279. DEFINE_PRIMITIVE ("%tkMoveWindow", Prim_tk_move, 3, 3, 0)
  280. { /* (%tkMoveWindow tkwin x y) */
  281.   PRIMITIVE_HEADER (3);
  282.   Tk_MoveWindow((Tk_Window) arg_integer(1),
  283.         (int) arg_integer(2),
  284.         (int) arg_integer(3));
  285.   PRIMITIVE_RETURN (UNSPECIFIC);
  286. }
  287.  
  288. DEFINE_PRIMITIVE ("%tkMoveResizeWindow", Prim_tk_move_resize, 5, 5, 0)
  289. { /* (%tkMoveResizeWindow tkwin x y width height) */
  290.   PRIMITIVE_HEADER (5);
  291.   Tk_MoveResizeWindow((Tk_Window) arg_integer(1),
  292.               (int) arg_integer(2), (int) arg_integer(3),
  293.               (unsigned int) arg_integer(4),
  294.               (unsigned int) arg_integer(5));
  295.   PRIMITIVE_RETURN (UNSPECIFIC);
  296. }
  297.  
  298. DEFINE_PRIMITIVE ("%tkNextWakeup", Prim_tk_next_wakeup, 0, 0, 0)
  299. { /* (%tkNextWakeup) */
  300.   /* If the call back list isn't empty, wake up right away. */
  301.   extern long tk_GetIntervalToNextEvent();
  302.   long Result =
  303.     (NChars_In_TK_Callbacks != 0) ? 0 : tk_GetIntervalToNextEvent();
  304.   
  305.   if (Result == -1)
  306.     PRIMITIVE_RETURN(SHARP_F);
  307.   else PRIMITIVE_RETURN(long_to_integer(Result));
  308. }
  309.  
  310. DEFINE_PRIMITIVE ("%tkResizeWindow", Prim_tk_resize, 3, 3, 0)
  311. { /* (%tkResizeWindow tkwin width height) */
  312.   PRIMITIVE_HEADER (3);
  313.   Tk_ResizeWindow((Tk_Window) arg_integer(1),
  314.         (int) arg_integer(2),
  315.         (int) arg_integer(3));
  316.   PRIMITIVE_RETURN (UNSPECIFIC);
  317. }
  318.  
  319. DEFINE_PRIMITIVE ("%tkUnmapWindow", Prim_tk_unmap_window, 1, 1, 0)
  320. { /* (%tkUnmapWindow tk-win) */
  321.   PRIMITIVE_HEADER (1);
  322.   Tk_UnmapWindow((Tk_Window) arg_integer(1));
  323.   PRIMITIVE_RETURN (UNSPECIFIC);
  324. }
  325.  
  326. DEFINE_PRIMITIVE ("%tkWinReqHeight", Prim_tk_win_req_height, 1, 1, 0)
  327. { /* (%tkwinReqHeight tk-win) */
  328.   PRIMITIVE_HEADER(1);
  329.   PRIMITIVE_RETURN (long_to_integer
  330.             ((long) Tk_ReqHeight (arg_integer(1))));
  331. }
  332.  
  333. DEFINE_PRIMITIVE ("%tkWinReqWidth", Prim_tk_win_req_width, 1, 1, 0)
  334. { /* (%tkwinReqWidth tk-win) */
  335.   PRIMITIVE_HEADER(1);
  336.   PRIMITIVE_RETURN (long_to_integer
  337.             ((long) Tk_ReqWidth (arg_integer(1))));
  338. }
  339.  
  340. DEFINE_PRIMITIVE ("%tkWidget.tkwin", Prim_tk_widget_get_tkwin, 1, 1, 0)
  341. { extern long /*Tk_Window*/ tk_tkwin_widget (long /*button*/ *button);
  342.   PRIMITIVE_HEADER(1);
  343.   PRIMITIVE_RETURN(long_to_integer
  344.            ((long) tk_tkwin_widget
  345.             ((long /*Button*/ *) arg_integer(1))));
  346. }
  347.  
  348. DEFINE_PRIMITIVE ("%tkWinDisplay", Prim_tk_win_display, 1, 1, 0)
  349. { /* (%tkwinDisplay tk-win) */
  350.   PRIMITIVE_HEADER(1);
  351.   PRIMITIVE_RETURN (long_to_integer
  352.             ((long) Tk_Display ((Tk_Window) arg_integer(1))));
  353. }
  354.  
  355. DEFINE_PRIMITIVE ("%tkWinIsMapped?", Prim_tk_win_is_mapped, 1, 1, 0)
  356. { /* (%tkwinismapped? tk-win) */
  357.   PRIMITIVE_HEADER(1);
  358.   PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT
  359.             (Tk_IsMapped ((Tk_Window) arg_integer(1))));
  360. }
  361.  
  362. DEFINE_PRIMITIVE ("%tkWinHeight", Prim_tk_win_height, 1, 1, 0)
  363. { /* (%tkwinHeight tk-win) */
  364.   PRIMITIVE_HEADER(1);
  365.   PRIMITIVE_RETURN (long_to_integer
  366.             ((long) Tk_Height ((Tk_Window) arg_integer(1))));
  367. }
  368.  
  369. DEFINE_PRIMITIVE ("%tkWinWidth", Prim_tk_win_width, 1, 1, 0)
  370. { /* (%tkwinWidth tk-win) */
  371.   PRIMITIVE_HEADER(1);
  372.   PRIMITIVE_RETURN (long_to_integer
  373.             ((long) Tk_Width ((Tk_Window) arg_integer(1))));
  374. }
  375.  
  376. DEFINE_PRIMITIVE ("%tkWinWindow", Prim_tk_win_window, 1, 1, 0)
  377. { /* (%tkwinWindow tk-win) */
  378.   PRIMITIVE_HEADER(1);
  379.   PRIMITIVE_RETURN (long_to_integer
  380.             ((long) Tk_WindowId ((Tk_Window) arg_integer(1))));
  381. }
  382.  
  383. DEFINE_PRIMITIVE ("%tkWinX", Prim_tk_win_x, 1, 1, 0)
  384. { /* (%tkwinx tk-win) */
  385.   PRIMITIVE_HEADER(1);
  386.   PRIMITIVE_RETURN (long_to_integer
  387.             ((long) Tk_X ((Tk_Window) arg_integer(1))));
  388. }
  389.  
  390. DEFINE_PRIMITIVE ("%tkWinY", Prim_tk_win_y, 1, 1, 0)
  391. { /* (%tkwiny tk-win) */
  392.   PRIMITIVE_HEADER(1);
  393.   PRIMITIVE_RETURN (long_to_integer
  394.             ((long) Tk_Y ((Tk_Window) arg_integer(1))));
  395. }
  396.  
  397. DEFINE_PRIMITIVE ("%tkWinName", Prim_tk_win_name, 1, 1, 0)
  398. { /* (%tkwinname tk-win) */
  399.   PRIMITIVE_HEADER(1);
  400.   PRIMITIVE_RETURN (char_pointer_to_string
  401.             ((unsigned char *) Tk_Name ((Tk_Window) arg_integer(1))));
  402. }
  403.  
  404. DEFINE_PRIMITIVE ("%tkWinPathName", Prim_tk_win_pathname, 1, 1, 0)
  405. { /* (%tkwinpathname tk-win) */
  406.   PRIMITIVE_HEADER(1);
  407.   PRIMITIVE_RETURN (char_pointer_to_string
  408.             ((unsigned char *) Tk_PathName ((Tk_Window) arg_integer(1))));
  409. }
  410.  
  411.