gdb/gdbtk.c

   1 /* TK interface routines.
   2    Copyright 1994 Free Software Foundation, Inc.
   3
   4 This file is part of GDB.
   5
   6 This program is free software; you can redistribute it and/or modify
   7 it under the terms of the GNU General Public License as published by
   8 the Free Software Foundation; either version 2 of the License, or
   9 (at your option) any later version.
  10
  11 This program is distributed in the hope that it will be useful,
  12 but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 GNU General Public License for more details.
  15
  16 You should have received a copy of the GNU General Public License
  17 along with this program; if not, write to the Free Software
  18 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.  */
  19
  20 #include "defs.h"
  21 #include "symtab.h"
  22 #include "inferior.h"
  23 #include "command.h"
  24 #include "bfd.h"
  25 #include "symfile.h"
  26 #include "objfiles.h"
  27 #include "target.h"
  28 #include <tcl.h>
  29 #include <tk.h>
  30 #include <varargs.h>
  31 #include <signal.h>
  32 #include <fcntl.h>
  33 #include <unistd.h>
  34 #include <setjmp.h>
  35 #include "top.h"
  36 #ifndef FASYNC
  37 #include <sys/stropts.h>
  38 #endif
  39 #include <string.h>
  40
  41 /* Non-zero means that we're doing the gdbtk interface. */
  42 int gdbtk = 0;
  43
  44 /* Non-zero means we are reloading breakpoints, etc from the
  45    Gdbtk kernel, and we should suppress various messages */
  46 static int gdbtk_reloading = 0;
  47
  48 /* Handle for TCL interpreter */
  49 static Tcl_Interp *interp = NULL;
  50
  51 /* Handle for TK main window */
  52 static Tk_Window mainWindow = NULL;
  53
  54 static int x_fd;                /* X network socket */
  55
  56 static void
  57 null_routine(arg)
  58      int arg;
  59 {
  60 }
  61
  62 /* The following routines deal with stdout/stderr data, which is created by
  63    {f}printf_{un}filtered and friends.  gdbtk_fputs and gdbtk_flush are the
  64    lowest level of these routines and capture all output from the rest of GDB.
  65    Normally they present their data to tcl via callbacks to the following tcl
  66    routines:  gdbtk_tcl_fputs, gdbtk_tcl_fputs_error, and gdbtk_flush.  These
  67    in turn call tk routines to update the display.
  68
  69    Under some circumstances, you may want to collect the output so that it can
  70    be returned as the value of a tcl procedure.  This can be done by
  71    surrounding the output routines with calls to start_saving_output and
  72    finish_saving_output.  The saved data can then be retrieved with
  73    get_saved_output (but this must be done before the call to
  74    finish_saving_output).  */
  75
  76 /* Dynamic string header for stdout. */
  77
  78 static Tcl_DString stdout_buffer;
  79
  80 /* Use this to collect stdout output that will be returned as the result of a
  81    tcl command.  */
  82
  83 static int saving_output = 0;
  84
  85 static void
  86 start_saving_output ()
  87 {
  88   saving_output = 1;
  89 }
  90
  91 #define get_saved_output() (Tcl_DStringValue (&stdout_buffer))
  92
  93 static void
  94 finish_saving_output ()
  95 {
  96   saving_output = 0;
  97
  98   Tcl_DStringFree (&stdout_buffer);
  99 }
 100 \f
 101 /* This routine redirects the output of fputs_unfiltered so that
 102    the user can see what's going on in his debugger window. */
 103
 104 static void
 105 flush_holdbuf ()
 106 {
 107   char *s, *argv[1];
 108
 109   /* We use Tcl_Merge to quote braces and funny characters as necessary. */
 110
 111   argv[0] = Tcl_DStringValue (&stdout_buffer);
 112   s = Tcl_Merge (1, argv);
 113
 114   Tcl_DStringFree (&stdout_buffer);
 115
 116   Tcl_VarEval (interp, "gdbtk_tcl_fputs ", s, NULL);
 117
 118   free (s);
 119 }
 120
 121 static void
 122 gdbtk_flush (stream)
 123      FILE *stream;
 124 {
 125   if (stream != gdb_stdout || saving_output)
 126     return;
 127
 128   /* Flush output from C to tcl land.  */
 129
 130   flush_holdbuf ();
 131
 132   /* Force immediate screen update */
 133
 134   Tcl_VarEval (interp, "gdbtk_tcl_flush", NULL);
 135 }
 136
 137 static void
 138 gdbtk_fputs (ptr, stream)
 139      const char *ptr;
 140      FILE *stream;
 141 {
 142   int len;
 143
 144   if (stream != gdb_stdout)
 145     {
 146       Tcl_VarEval (interp, "gdbtk_tcl_fputs_error ", "{", ptr, "}", NULL);
 147       return;
 148     }
 149
 150   Tcl_DStringAppend (&stdout_buffer, ptr, -1);
 151
 152   if (saving_output)
 153     return;
 154
 155   if (Tcl_DStringLength (&stdout_buffer) > 1000)
 156     flush_holdbuf ();
 157 }
 158
 159 static int
 160 gdbtk_query (args)
 161      va_list args;
 162 {
 163   char *query;
 164   char buf[200];
 165   long val;
 166
 167   query = va_arg (args, char *);
 168
 169   vsprintf(buf, query, args);
 170   Tcl_VarEval (interp, "gdbtk_tcl_query ", "{", buf, "}", NULL);
 171
 172   val = atol (interp->result);
 173   return val;
 174 }
 175 \f
 176 static void
 177 breakpoint_notify(b, action)
 178      struct breakpoint *b;
 179      const char *action;
 180 {
 181   struct symbol *sym;
 182   char bpnum[50], line[50], pc[50];
 183   struct symtab_and_line sal;
 184   char *filename;
 185   int v;
 186
 187   if (b->type != bp_breakpoint)
 188     return;
 189
 190   sal = find_pc_line (b->address, 0);
 191
 192   filename = symtab_to_filename (sal.symtab);
 193
 194   sprintf (bpnum, "%d", b->number);
 195   sprintf (line, "%d", sal.line);
 196   sprintf (pc, "0x%lx", b->address);
 197
 198   v = Tcl_VarEval (interp,
 199                    "gdbtk_tcl_breakpoint ",
 200                    action,
 201                    " ", bpnum,
 202                    " ", filename,
 203                    " ", line,
 204                    " ", pc,
 205                    NULL);
 206
 207   if (v != TCL_OK)
 208     {
 209       gdbtk_fputs (interp->result, gdb_stdout);
 210       gdbtk_fputs ("\n", gdb_stdout);
 211     }
 212 }
 213
 214 static void
 215 gdbtk_create_breakpoint(b)
 216      struct breakpoint *b;
 217 {
 218   breakpoint_notify(b, "create");
 219 }
 220
 221 static void
 222 gdbtk_delete_breakpoint(b)
 223      struct breakpoint *b;
 224 {
 225   breakpoint_notify(b, "delete");
 226 }
 227
 228 static void
 229 gdbtk_enable_breakpoint(b)
 230      struct breakpoint *b;
 231 {
 232   breakpoint_notify(b, "enable");
 233 }
 234
 235 static void
 236 gdbtk_disable_breakpoint(b)
 237      struct breakpoint *b;
 238 {
 239   breakpoint_notify(b, "disable");
 240 }
 241 \f
 242 /* This implements the TCL command `gdb_loc', which returns a list consisting
 243    of the source and line number associated with the current pc. */
 244
 245 static int
 246 gdb_loc (clientData, interp, argc, argv)
 247      ClientData clientData;
 248      Tcl_Interp *interp;
 249      int argc;
 250      char *argv[];
 251 {
 252   char *filename;
 253   char buf[100];
 254   struct symtab_and_line sal;
 255   char *funcname;
 256   CORE_ADDR pc;
 257
 258   if (argc == 1)
 259     {
 260       pc = selected_frame ? selected_frame->pc : stop_pc;
 261       sal = find_pc_line (pc, 0);
 262     }
 263   else if (argc == 2)
 264     {
 265       struct symtabs_and_lines sals;
 266       int nelts;
 267
 268       sals = decode_line_spec (argv[1], 1);
 269
 270       nelts = sals.nelts;
 271       sal = sals.sals[0];
 272       free (sals.sals);
 273
 274       if (sals.nelts != 1)
 275         {
 276           Tcl_SetResult (interp, "Ambiguous line spec", TCL_STATIC);
 277           return TCL_ERROR;
 278         }
 279
 280       pc = sal.pc;
 281     }
 282   else
 283     {
 284       Tcl_SetResult (interp, "wrong # args", TCL_STATIC);
 285       return TCL_ERROR;
 286     }
 287
 288   if (sal.symtab)
 289     Tcl_AppendElement (interp, sal.symtab->filename);
 290   else
 291     Tcl_AppendElement (interp, "");
 292
 293   find_pc_partial_function (pc, &funcname, NULL, NULL);
 294   Tcl_AppendElement (interp, funcname);
 295
 296   filename = symtab_to_filename (sal.symtab);
 297   Tcl_AppendElement (interp, filename);
 298
 299   sprintf (buf, "%d", sal.line);
 300   Tcl_AppendElement (interp, buf); /* line number */
 301
 302   sprintf (buf, "0x%lx", pc);
 303   Tcl_AppendElement (interp, buf); /* PC */
 304
 305   return TCL_OK;
 306 }
 307 \f
 308 /* This implements the TCL command `gdb_sourcelines', which returns a list of
 309    all of the lines containing executable code for the specified source file
 310    (ie: lines where you can put breakpoints). */
 311
 312 static int
 313 gdb_sourcelines (clientData, interp, argc, argv)
 314      ClientData clientData;
 315      Tcl_Interp *interp;
 316      int argc;
 317      char *argv[];
 318 {
 319   struct symtab *symtab;
 320   struct linetable_entry *le;
 321   int nlines;
 322   char buf[100];
 323
 324   if (argc != 2)
 325     {
 326       Tcl_SetResult (interp, "wrong # args", TCL_STATIC);
 327       return TCL_ERROR;
 328     }
 329
 330   symtab = lookup_symtab (argv[1]);
 331
 332   if (!symtab)
 333     {
 334       Tcl_SetResult (interp, "No such file", TCL_STATIC);
 335       return TCL_ERROR;
 336     }
 337
 338   /* If there's no linetable, or no entries, then we are done. */
 339
 340   if (!symtab->linetable
 341       || symtab->linetable->nitems == 0)
 342     {
 343       Tcl_AppendElement (interp, "");
 344       return TCL_OK;
 345     }
 346
 347   le = symtab->linetable->item;
 348   nlines = symtab->linetable->nitems;
 349
 350   for (;nlines > 0; nlines--, le++)
 351     {
 352       /* If the pc of this line is the same as the pc of the next line, then
 353          just skip it.  */
 354       if (nlines > 1
 355           && le->pc == (le + 1)->pc)
 356         continue;
 357
 358       sprintf (buf, "%d", le->line);
 359       Tcl_AppendElement (interp, buf);
 360     }
 361
 362   return TCL_OK;
 363 }
 364 \f
 365 static int
 366 map_arg_registers (argc, argv, func, argp)
 367      int argc;
 368      char *argv[];
 369      int (*func) PARAMS ((int regnum, void *argp));
 370      void *argp;
 371 {
 372   int regnum;
 373
 374   /* Note that the test for a valid register must include checking the
 375      reg_names array because NUM_REGS may be allocated for the union of the
 376      register sets within a family of related processors.  In this case, the
 377      trailing entries of reg_names will change depending upon the particular
 378      processor being debugged.  */
 379
 380   if (argc == 0)                /* No args, just do all the regs */
 381     {
 382       for (regnum = 0;
 383            regnum < NUM_REGS
 384            && reg_names[regnum] != NULL
 385            && *reg_names[regnum] != '\000';
 386            regnum++)
 387         func (regnum, argp);
 388
 389       return TCL_OK;
 390     }
 391
 392   /* Else, list of register #s, just do listed regs */
 393   for (; argc > 0; argc--, argv++)
 394     {
 395       regnum = atoi (*argv);
 396
 397       if (regnum >= 0
 398           && regnum < NUM_REGS
 399           && reg_names[regnum] != NULL
 400           && *reg_names[regnum] != '\000')
 401         func (regnum, argp);
 402       else
 403         {
 404           Tcl_SetResult (interp, "bad register number", TCL_STATIC);
 405
 406           return TCL_ERROR;
 407         }
 408     }
 409
 410   return TCL_OK;
 411 }
 412
 413 static int
 414 get_register_name (regnum, argp)
 415      int regnum;
 416      void *argp;                /* Ignored */
 417 {
 418   Tcl_AppendElement (interp, reg_names[regnum]);
 419 }
 420
 421 /* This implements the TCL command `gdb_regnames', which returns a list of
 422    all of the register names. */
 423
 424 static int
 425 gdb_regnames (clientData, interp, argc, argv)
 426      ClientData clientData;
 427      Tcl_Interp *interp;
 428      int argc;
 429      char *argv[];
 430 {
 431   argc--;
 432   argv++;
 433
 434   return map_arg_registers (argc, argv, get_register_name, 0);
 435 }
 436
 437 #ifndef REGISTER_CONVERTIBLE
 438 #define REGISTER_CONVERTIBLE(x) (0 != 0)
 439 #endif
 440
 441 #ifndef REGISTER_CONVERT_TO_VIRTUAL
 442 #define REGISTER_CONVERT_TO_VIRTUAL(x, y, z, a)
 443 #endif
 444
 445 #ifndef INVALID_FLOAT
 446 #define INVALID_FLOAT(x, y) (0 != 0)
 447 #endif
 448
 449 static int
 450 get_register (regnum, fp)
 451      void *fp;
 452 {
 453   char raw_buffer[MAX_REGISTER_RAW_SIZE];
 454   char virtual_buffer[MAX_REGISTER_VIRTUAL_SIZE];
 455   int format = (int)fp;
 456
 457   if (read_relative_register_raw_bytes (regnum, raw_buffer))
 458     {
 459       Tcl_AppendElement (interp, "Optimized out");
 460       return;
 461     }
 462
 463   start_saving_output ();       /* Start collecting stdout */
 464
 465   /* Convert raw data to virtual format if necessary.  */
 466
 467   if (REGISTER_CONVERTIBLE (regnum))
 468     {
 469       REGISTER_CONVERT_TO_VIRTUAL (regnum, REGISTER_VIRTUAL_TYPE (regnum),
 470                                    raw_buffer, virtual_buffer);
 471     }
 472   else
 473     memcpy (virtual_buffer, raw_buffer, REGISTER_VIRTUAL_SIZE (regnum));
 474
 475   val_print (REGISTER_VIRTUAL_TYPE (regnum), virtual_buffer, 0,
 476              gdb_stdout, format, 1, 0, Val_pretty_default);
 477
 478   Tcl_AppendElement (interp, get_saved_output ());
 479
 480   finish_saving_output ();      /* Set stdout back to normal */
 481 }
 482
 483 static int
 484 gdb_fetch_registers (clientData, interp, argc, argv)
 485      ClientData clientData;
 486      Tcl_Interp *interp;
 487      int argc;
 488      char *argv[];
 489 {
 490   int format;
 491
 492   if (argc < 2)
 493     {
 494       Tcl_SetResult (interp, "wrong # args", TCL_STATIC);
 495       return TCL_ERROR;
 496     }
 497
 498   argc--;
 499   argv++;
 500
 501   argc--;
 502   format = **argv++;
 503
 504   return map_arg_registers (argc, argv, get_register, format);
 505 }
 506
 507 /* This contains the previous values of the registers, since the last call to
 508    gdb_changed_register_list.  */
 509
 510 static char old_regs[REGISTER_BYTES];
 511
 512 static int
 513 register_changed_p (regnum, argp)
 514      void *argp;                /* Ignored */
 515 {
 516   char raw_buffer[MAX_REGISTER_RAW_SIZE];
 517   char buf[100];
 518
 519   if (read_relative_register_raw_bytes (regnum, raw_buffer))
 520     return;
 521
 522   if (memcmp (&old_regs[REGISTER_BYTE (regnum)], raw_buffer,
 523               REGISTER_RAW_SIZE (regnum)) == 0)
 524     return;
 525
 526   /* Found a changed register.  Save new value and return it's number. */
 527
 528   memcpy (&old_regs[REGISTER_BYTE (regnum)], raw_buffer,
 529           REGISTER_RAW_SIZE (regnum));
 530
 531   sprintf (buf, "%d", regnum);
 532   Tcl_AppendElement (interp, buf);
 533 }
 534
 535 static int
 536 gdb_changed_register_list (clientData, interp, argc, argv)
 537      ClientData clientData;
 538      Tcl_Interp *interp;
 539      int argc;
 540      char *argv[];
 541 {
 542   int format;
 543
 544   argc--;
 545   argv++;
 546
 547   return map_arg_registers (argc, argv, register_changed_p, NULL);
 548 }
 549 \f
 550 /* This implements the TCL command `gdb_cmd', which sends it's argument into
 551    the GDB command scanner.  */
 552
 553 static int
 554 gdb_cmd (clientData, interp, argc, argv)
 555      ClientData clientData;
 556      Tcl_Interp *interp;
 557      int argc;
 558      char *argv[];
 559 {
 560   if (argc != 2)
 561     {
 562       Tcl_SetResult (interp, "wrong # args", TCL_STATIC);
 563       return TCL_ERROR;
 564     }
 565
 566   execute_command (argv[1], 1);
 567
 568   bpstat_do_actions (&stop_bpstat);
 569
 570   /* Drain all buffered command output */
 571
 572   gdb_flush (gdb_stdout);
 573
 574   return TCL_OK;
 575 }
 576
 577 /* This routine acts as a top-level for all GDB code called by tcl/Tk.  It
 578    handles cleanups, and calls to return_to_top_level (usually via error).
 579    This is necessary in order to prevent a longjmp out of the bowels of Tk,
 580    possibly leaving things in a bad state.  Since this routine can be called
 581    recursively, it needs to save and restore the contents of the jmp_buf as
 582    necessary.  */
 583
 584 static int
 585 call_wrapper (clientData, interp, argc, argv)
 586      ClientData clientData;
 587      Tcl_Interp *interp;
 588      int argc;
 589      char *argv[];
 590 {
 591   int val;
 592   struct cleanup *saved_cleanup_chain;
 593   Tcl_CmdProc *func;
 594   jmp_buf saved_error_return;
 595
 596   func = (Tcl_CmdProc *)clientData;
 597   memcpy (saved_error_return, error_return, sizeof (jmp_buf));
 598
 599   saved_cleanup_chain = save_cleanups ();
 600
 601   if (!setjmp (error_return))
 602     val = func (clientData, interp, argc, argv);
 603   else
 604     {
 605       val = TCL_ERROR;          /* Flag an error for TCL */
 606
 607       finish_saving_output ();  /* Restore stdout to normal */
 608
 609       gdb_flush (gdb_stderr);   /* Flush error output */
 610
 611 /* In case of an error, we may need to force the GUI into idle mode because
 612    gdbtk_call_command may have bombed out while in the command routine.  */
 613
 614       Tcl_VarEval (interp, "gdbtk_tcl_idle", NULL);
 615     }
 616
 617   do_cleanups (ALL_CLEANUPS);
 618
 619   restore_cleanups (saved_cleanup_chain);
 620
 621   memcpy (error_return, saved_error_return, sizeof (jmp_buf));
 622
 623   return val;
 624 }
 625
 626 static int
 627 gdb_listfiles (clientData, interp, argc, argv)
 628      ClientData clientData;
 629      Tcl_Interp *interp;
 630      int argc;
 631      char *argv[];
 632 {
 633   int val;
 634   struct objfile *objfile;
 635   struct partial_symtab *psymtab;
 636   struct symtab *symtab;
 637
 638   ALL_PSYMTABS (objfile, psymtab)
 639     Tcl_AppendElement (interp, psymtab->filename);
 640
 641   ALL_SYMTABS (objfile, symtab)
 642     Tcl_AppendElement (interp, symtab->filename);
 643
 644   return TCL_OK;
 645 }
 646
 647 static int
 648 gdb_stop (clientData, interp, argc, argv)
 649      ClientData clientData;
 650      Tcl_Interp *interp;
 651      int argc;
 652      char *argv[];
 653 {
 654   target_stop ();
 655
 656   return TCL_OK;
 657 }
 658
 659 \f
 660 static void
 661 tk_command (cmd, from_tty)
 662      char *cmd;
 663      int from_tty;
 664 {
 665   int retval;
 666   char *result;
 667   struct cleanup *old_chain;
 668
 669   retval = Tcl_Eval (interp, cmd);
 670
 671   result = strdup (interp->result);
 672
 673   old_chain = make_cleanup (free, result);
 674
 675   if (retval != TCL_OK)
 676     error (result);
 677
 678   printf_unfiltered ("%s\n", result);
 679
 680   do_cleanups (old_chain);
 681 }
 682
 683 static void
 684 cleanup_init (ignored)
 685      int ignored;
 686 {
 687   if (mainWindow != NULL)
 688     Tk_DestroyWindow (mainWindow);
 689   mainWindow = NULL;
 690
 691   if (interp != NULL)
 692     Tcl_DeleteInterp (interp);
 693   interp = NULL;
 694 }
 695
 696 /* Come here during long calculations to check for GUI events.  Usually invoked
 697    via the QUIT macro.  */
 698
 699 static void
 700 gdbtk_interactive ()
 701 {
 702   /* Tk_DoOneEvent (TK_DONT_WAIT|TK_IDLE_EVENTS); */
 703 }
 704
 705 /* Come here when there is activity on the X file descriptor. */
 706
 707 static void
 708 x_event (signo)
 709      int signo;
 710 {
 711   /* Process pending events */
 712
 713   while (Tk_DoOneEvent (TK_DONT_WAIT|TK_ALL_EVENTS) != 0);
 714 }
 715
 716 static int
 717 gdbtk_wait (pid, ourstatus)
 718      int pid;
 719      struct target_waitstatus *ourstatus;
 720 {
 721 #ifdef FASYNC
 722   signal (SIGIO, x_event);
 723 #else
 724 #if 1
 725   sigset (SIGIO, x_event);
 726 #else
 727   /* This is possibly needed for SVR4... */
 728   {
 729     struct sigaction action;
 730     static sigset_t nullsigmask = {0};
 731
 732     action.sa_handler = iosig;
 733     action.sa_mask = nullsigmask;
 734     action.sa_flags = SA_RESTART;
 735     sigaction(SIGIO, &action, NULL);
 736   }
 737 #endif
 738 #endif
 739
 740   pid = target_wait (pid, ourstatus);
 741
 742   signal (SIGIO, SIG_IGN);
 743
 744   return pid;
 745 }
 746
 747 /* This is called from execute_command, and provides a wrapper around
 748    various command routines in a place where both protocol messages and
 749    user input both flow through.  Mostly this is used for indicating whether
 750    the target process is running or not.
 751 */
 752
 753 static void
 754 gdbtk_call_command (cmdblk, arg, from_tty)
 755      struct cmd_list_element *cmdblk;
 756      char *arg;
 757      int from_tty;
 758 {
 759   if (cmdblk->class == class_run)
 760     {
 761       Tcl_VarEval (interp, "gdbtk_tcl_busy", NULL);
 762       (*cmdblk->function.cfunc)(arg, from_tty);
 763       Tcl_VarEval (interp, "gdbtk_tcl_idle", NULL);
 764     }
 765   else
 766     (*cmdblk->function.cfunc)(arg, from_tty);
 767 }
 768
 769 static void
 770 gdbtk_init ()
 771 {
 772   struct cleanup *old_chain;
 773   char *gdbtk_filename;
 774   int i;
 775
 776   old_chain = make_cleanup (cleanup_init, 0);
 777
 778   /* First init tcl and tk. */
 779
 780   interp = Tcl_CreateInterp ();
 781
 782   if (!interp)
 783     error ("Tcl_CreateInterp failed");
 784
 785   Tcl_DStringInit (&stdout_buffer); /* Setup stdout buffer */
 786
 787   mainWindow = Tk_CreateMainWindow (interp, NULL, "gdb", "Gdb");
 788
 789   if (!mainWindow)
 790     return;                     /* DISPLAY probably not set */
 791
 792   if (Tcl_Init(interp) != TCL_OK)
 793     error ("Tcl_Init failed: %s", interp->result);
 794
 795   if (Tk_Init(interp) != TCL_OK)
 796     error ("Tk_Init failed: %s", interp->result);
 797
 798   Tcl_CreateCommand (interp, "gdb_cmd", call_wrapper, gdb_cmd, NULL);
 799   Tcl_CreateCommand (interp, "gdb_loc", call_wrapper, gdb_loc, NULL);
 800   Tcl_CreateCommand (interp, "gdb_sourcelines", call_wrapper, gdb_sourcelines,
 801                      NULL);
 802   Tcl_CreateCommand (interp, "gdb_listfiles", call_wrapper, gdb_listfiles,
 803                      NULL);
 804   Tcl_CreateCommand (interp, "gdb_stop", call_wrapper, gdb_stop, NULL);
 805   Tcl_CreateCommand (interp, "gdb_regnames", call_wrapper, gdb_regnames, NULL);
 806   Tcl_CreateCommand (interp, "gdb_fetch_registers", call_wrapper,
 807                      gdb_fetch_registers, NULL);
 808   Tcl_CreateCommand (interp, "gdb_changed_register_list", call_wrapper,
 809                      gdb_changed_register_list, NULL);
 810
 811   gdbtk_filename = getenv ("GDBTK_FILENAME");
 812   if (!gdbtk_filename)
 813     if (access ("gdbtk.tcl", R_OK) == 0)
 814       gdbtk_filename = "gdbtk.tcl";
 815     else
 816       gdbtk_filename = GDBTK_FILENAME;
 817
 818   if (Tcl_EvalFile (interp, gdbtk_filename) != TCL_OK)
 819     error ("Failure reading %s: %s", gdbtk_filename, interp->result);
 820
 821   /* Get the file descriptor for the X server */
 822
 823   x_fd = ConnectionNumber (Tk_Display (mainWindow));
 824
 825   /* Setup for I/O interrupts */
 826
 827   signal (SIGIO, SIG_IGN);
 828
 829 #ifdef FASYNC
 830   i = fcntl (x_fd, F_GETFL, 0);
 831   fcntl (x_fd, F_SETFL, i|FASYNC);
 832   fcntl (x_fd, F_SETOWN, getpid());
 833 #else
 834   if (ioctl (x_fd,  I_SETSIG, S_INPUT|S_RDNORM) < 0)
 835     perror ("gdbtk_init: ioctl I_SETSIG failed");
 836 #endif /* ifndef FASYNC */
 837
 838   command_loop_hook = Tk_MainLoop;
 839   fputs_unfiltered_hook = gdbtk_fputs;
 840   print_frame_info_listing_hook = null_routine;
 841   query_hook = gdbtk_query;
 842   flush_hook = gdbtk_flush;
 843   create_breakpoint_hook = gdbtk_create_breakpoint;
 844   delete_breakpoint_hook = gdbtk_delete_breakpoint;
 845   enable_breakpoint_hook = gdbtk_enable_breakpoint;
 846   disable_breakpoint_hook = gdbtk_disable_breakpoint;
 847   interactive_hook = gdbtk_interactive;
 848   target_wait_hook = gdbtk_wait;
 849   call_command_hook = gdbtk_call_command;
 850
 851   discard_cleanups (old_chain);
 852
 853   add_com ("tk", class_obscure, tk_command,
 854            "Send a command directly into tk.");
 855 }
 856
 857 /* Come here during initialze_all_files () */
 858
 859 void
 860 _initialize_gdbtk ()
 861 {
 862   if (use_windows)
 863     {
 864       /* Tell the rest of the world that Gdbtk is now set up. */
 865
 866       init_ui_hook = gdbtk_init;
 867     }
 868 }