gdb/gdbtk.c

   1 /* Tcl/Tk interface routines.
   2    Copyright 1994, 1995, 1996, 1997 Free Software Foundation, Inc.
   3
   4    Written by Stu Grossman <grossman@cygnus.com> of Cygnus Support.
   5
   6 This file is part of GDB.
   7
   8 This program is free software; you can redistribute it and/or modify
   9 it under the terms of the GNU General Public License as published by
  10 the Free Software Foundation; either version 2 of the License, or
  11 (at your option) any later version.
  12
  13 This program is distributed in the hope that it will be useful,
  14 but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 GNU General Public License for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with this program; if not, write to the Free Software
  20 Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.  */
  21
  22 #include "defs.h"
  23 #include "symtab.h"
  24 #include "inferior.h"
  25 #include "command.h"
  26 #include "bfd.h"
  27 #include "symfile.h"
  28 #include "objfiles.h"
  29 #include "target.h"
  30 #include <tcl.h>
  31 #include <tk.h>
  32 #include <itcl.h>
  33 #include <tix.h>
  34
  35 #ifdef IDE
  36 #include "event.h"
  37 #include "idetcl.h"
  38 #endif
  39
  40 #ifdef ANSI_PROTOTYPES
  41 #include <stdarg.h>
  42 #else
  43 #include <varargs.h>
  44 #endif
  45 #include <signal.h>
  46 #include <fcntl.h>
  47 #include <unistd.h>
  48 #include <setjmp.h>
  49 #include "top.h"
  50 #include <sys/ioctl.h>
  51 #include "gdb_string.h"
  52 #include "dis-asm.h"
  53 #include <stdio.h>
  54 #include "gdbcmd.h"
  55
  56 #ifndef WINNT
  57 #ifndef FIOASYNC
  58 #include <sys/stropts.h>
  59 #endif
  60 #endif
  61
  62 #ifdef WINNT
  63 #define GDBTK_PATH_SEP ";"
  64 #else
  65 #define GDBTK_PATH_SEP ":"
  66 #endif
  67
  68 /* Some versions (1.3.79, 1.3.81) of Linux don't support SIOCSPGRP the way
  69    gdbtk wants to use it... */
  70 #ifdef __linux__
  71 #undef SIOCSPGRP
  72 #endif
  73
  74 static void null_routine PARAMS ((int));
  75 static void gdbtk_flush PARAMS ((FILE *));
  76 static void gdbtk_fputs PARAMS ((const char *, FILE *));
  77 static int gdbtk_query PARAMS ((const char *, va_list));
  78 static char *gdbtk_readline PARAMS ((char *));
  79 static void gdbtk_init PARAMS ((char *));
  80 static void tk_command_loop PARAMS ((void));
  81 static void gdbtk_call_command PARAMS ((struct cmd_list_element *, char *, int));
  82 static int gdbtk_wait PARAMS ((int, struct target_waitstatus *));
  83 static void x_event PARAMS ((int));
  84 static void gdbtk_interactive PARAMS ((void));
  85 static void cleanup_init PARAMS ((int));
  86 static void tk_command PARAMS ((char *, int));
  87 static int gdb_disassemble PARAMS ((ClientData, Tcl_Interp *, int, char *[]));
  88 static int compare_lines PARAMS ((const PTR, const PTR));
  89 static int gdbtk_dis_asm_read_memory PARAMS ((bfd_vma, bfd_byte *, int, disassemble_info *));
  90 static int gdb_path_conv PARAMS ((ClientData, Tcl_Interp *, int, char *[]));
  91 static int gdb_stop PARAMS ((ClientData, Tcl_Interp *, int, char *[]));
  92 static int gdb_listfiles PARAMS ((ClientData, Tcl_Interp *, int, char *[]));
  93 static int call_wrapper PARAMS ((ClientData, Tcl_Interp *, int, char *[]));
  94 static int gdb_cmd PARAMS ((ClientData, Tcl_Interp *, int, char *argv[]));
  95 static int gdb_fetch_registers PARAMS ((ClientData, Tcl_Interp *, int, char *[]));
  96 static void gdbtk_readline_end PARAMS ((void));
  97 static int gdb_changed_register_list PARAMS ((ClientData, Tcl_Interp *, int, char *[]));
  98 static void register_changed_p PARAMS ((int, void *));
  99 static int gdb_get_breakpoint_list PARAMS ((ClientData, Tcl_Interp *, int, char *[]));
 100 static int gdb_get_breakpoint_info PARAMS ((ClientData, Tcl_Interp *, int, char *[]));
 101 static void breakpoint_notify PARAMS ((struct breakpoint *, const char *));
 102 static void gdbtk_create_breakpoint PARAMS ((struct breakpoint *));
 103 static void gdbtk_delete_breakpoint PARAMS ((struct breakpoint *));
 104 static void gdbtk_modify_breakpoint PARAMS ((struct breakpoint *));
 105 static int gdb_loc PARAMS ((ClientData, Tcl_Interp *, int, char *[]));
 106 static int gdb_eval PARAMS ((ClientData, Tcl_Interp *, int, char *[]));
 107 static int gdb_sourcelines PARAMS ((ClientData, Tcl_Interp *, int, char *[]));
 108 static int map_arg_registers PARAMS ((int, char *[], void (*) (int, void *), void *));
 109 static void get_register_name PARAMS ((int, void *));
 110 static int gdb_regnames PARAMS ((ClientData, Tcl_Interp *, int, char *[]));
 111 static void get_register PARAMS ((int, void *));
 112
 113 /* Handle for TCL interpreter */
 114
 115 static Tcl_Interp *interp = NULL;
 116
 117 static int x_fd;                /* X network socket */
 118
 119 /* This variable is true when the inferior is running.  Although it's
 120    possible to disable most input from widgets and thus prevent
 121    attempts to do anything while the inferior is running, any commands
 122    that get through - even a simple memory read - are Very Bad, and
 123    may cause GDB to crash or behave strangely.  So, this variable
 124    provides an extra layer of defense.  */
 125
 126 static int running_now;
 127
 128 /* This variable determines where memory used for disassembly is read from.
 129    If > 0, then disassembly comes from the exec file rather than the
 130    target (which might be at the other end of a slow serial link).  If
 131    == 0 then disassembly comes from target.  If < 0 disassembly is
 132    automatically switched to the target if it's an inferior process,
 133    otherwise the exec file is used.  */
 134
 135 static int disassemble_from_exec = -1;
 136
 137 /* Supply malloc calls for tcl/tk.  */
 138
 139 char *
 140 Tcl_Alloc (size)
 141      unsigned int size;
 142 {
 143   return xmalloc (size);
 144 }
 145
 146 char *
 147 Tcl_Realloc (ptr, size)
 148      char *ptr;
 149      unsigned int size;
 150 {
 151   return xrealloc (ptr, size);
 152 }
 153
 154 void
 155 Tcl_Free(ptr)
 156      char *ptr;
 157 {
 158   free (ptr);
 159 }
 160
 161 static void
 162 null_routine(arg)
 163      int arg;
 164 {
 165 }
 166
 167 /* The following routines deal with stdout/stderr data, which is created by
 168    {f}printf_{un}filtered and friends.  gdbtk_fputs and gdbtk_flush are the
 169    lowest level of these routines and capture all output from the rest of GDB.
 170    Normally they present their data to tcl via callbacks to the following tcl
 171    routines:  gdbtk_tcl_fputs, gdbtk_tcl_fputs_error, and gdbtk_flush.  These
 172    in turn call tk routines to update the display.
 173
 174    Under some circumstances, you may want to collect the output so that it can
 175    be returned as the value of a tcl procedure.  This can be done by
 176    surrounding the output routines with calls to start_saving_output and
 177    finish_saving_output.  The saved data can then be retrieved with
 178    get_saved_output (but this must be done before the call to
 179    finish_saving_output).  */
 180
 181 /* Dynamic string header for stdout. */
 182
 183 static Tcl_DString *result_ptr;
 184 \f
 185 static void
 186 gdbtk_flush (stream)
 187      FILE *stream;
 188 {
 189 #if 0
 190   /* Force immediate screen update */
 191
 192   Tcl_VarEval (interp, "gdbtk_tcl_flush", NULL);
 193 #endif
 194 }
 195
 196 static void
 197 gdbtk_fputs (ptr, stream)
 198      const char *ptr;
 199      FILE *stream;
 200 {
 201   if (result_ptr)
 202     Tcl_DStringAppend (result_ptr, (char *)ptr, -1);
 203   else
 204     {
 205       Tcl_DString str;
 206
 207       Tcl_DStringInit (&str);
 208
 209       Tcl_DStringAppend (&str, "gdbtk_tcl_fputs", -1);
 210       Tcl_DStringAppendElement (&str, (char *)ptr);
 211
 212       Tcl_Eval (interp, Tcl_DStringValue (&str));
 213       Tcl_DStringFree (&str);
 214     }
 215 }
 216
 217 static int
 218 gdbtk_query (query, args)
 219      const char *query;
 220      va_list args;
 221 {
 222   char buf[200], *merge[2];
 223   char *command;
 224   long val;
 225
 226   vsprintf (buf, query, args);
 227   merge[0] = "gdbtk_tcl_query";
 228   merge[1] = buf;
 229   command = Tcl_Merge (2, merge);
 230   Tcl_Eval (interp, command);
 231   free (command);
 232
 233   val = atol (interp->result);
 234   return val;
 235 }
 236
 237 /* VARARGS */
 238 static void
 239 #ifdef ANSI_PROTOTYPES
 240 gdbtk_readline_begin (char *format, ...)
 241 #else
 242 gdbtk_readline_begin (va_alist)
 243      va_dcl
 244 #endif
 245 {
 246   va_list args;
 247   char buf[200], *merge[2];
 248   char *command;
 249
 250 #ifdef ANSI_PROTOTYPES
 251   va_start (args, format);
 252 #else
 253   char *format;
 254   va_start (args);
 255   format = va_arg (args, char *);
 256 #endif
 257
 258   vsprintf (buf, format, args);
 259   merge[0] = "gdbtk_tcl_readline_begin";
 260   merge[1] = buf;
 261   command = Tcl_Merge (2, merge);
 262   Tcl_Eval (interp, command);
 263   free (command);
 264 }
 265
 266 static char *
 267 gdbtk_readline (prompt)
 268      char *prompt;
 269 {
 270   char *merge[2];
 271   char *command;
 272   int result;
 273
 274   merge[0] = "gdbtk_tcl_readline";
 275   merge[1] = prompt;
 276   command = Tcl_Merge (2, merge);
 277   result = Tcl_Eval (interp, command);
 278   free (command);
 279   if (result == TCL_OK)
 280     {
 281       return (strdup (interp -> result));
 282     }
 283   else
 284     {
 285       gdbtk_fputs (interp -> result, gdb_stdout);
 286       gdbtk_fputs ("\n", gdb_stdout);
 287       return (NULL);
 288     }
 289 }
 290
 291 static void
 292 gdbtk_readline_end ()
 293 {
 294   Tcl_Eval (interp, "gdbtk_tcl_readline_end");
 295 }
 296
 297 \f
 298 static void
 299 #ifdef ANSI_PROTOTYPES
 300 dsprintf_append_element (Tcl_DString *dsp, char *format, ...)
 301 #else
 302 dsprintf_append_element (va_alist)
 303      va_dcl
 304 #endif
 305 {
 306   va_list args;
 307   char buf[1024];
 308
 309 #ifdef ANSI_PROTOTYPES
 310   va_start (args, format);
 311 #else
 312   Tcl_DString *dsp;
 313   char *format;
 314
 315   va_start (args);
 316   dsp = va_arg (args, Tcl_DString *);
 317   format = va_arg (args, char *);
 318 #endif
 319
 320   vsprintf (buf, format, args);
 321
 322   Tcl_DStringAppendElement (dsp, buf);
 323 }
 324
 325 static int
 326 gdb_path_conv (clientData, interp, argc, argv)
 327      ClientData clientData;
 328      Tcl_Interp *interp;
 329      int argc;
 330      char *argv[];
 331 {
 332 #ifdef WINNT
 333   char pathname[256], *ptr;
 334   if (argc != 2)
 335     error ("wrong # args");
 336   cygwin32_conv_to_full_win32_path (argv[1], pathname);
 337   for (ptr = pathname; *ptr; ptr++)
 338     {
 339       if (*ptr == '\\')
 340         *ptr = '/';
 341     }
 342 #else
 343   char *pathname = argv[1];
 344 #endif
 345   Tcl_DStringAppend (result_ptr, pathname, strlen(pathname));
 346   return TCL_OK;
 347 }
 348
 349 static int
 350 gdb_get_breakpoint_list (clientData, interp, argc, argv)
 351      ClientData clientData;
 352      Tcl_Interp *interp;
 353      int argc;
 354      char *argv[];
 355 {
 356   struct breakpoint *b;
 357   extern struct breakpoint *breakpoint_chain;
 358
 359   if (argc != 1)
 360     error ("wrong # args");
 361
 362   for (b = breakpoint_chain; b; b = b->next)
 363     if (b->type == bp_breakpoint)
 364       dsprintf_append_element (result_ptr, "%d", b->number);
 365
 366   return TCL_OK;
 367 }
 368
 369 static int
 370 gdb_get_breakpoint_info (clientData, interp, argc, argv)
 371      ClientData clientData;
 372      Tcl_Interp *interp;
 373      int argc;
 374      char *argv[];
 375 {
 376   struct symtab_and_line sal;
 377   static char *bptypes[] = {"breakpoint", "hardware breakpoint", "until",
 378                               "finish", "watchpoint", "hardware watchpoint",
 379                               "read watchpoint", "access watchpoint",
 380                               "longjmp", "longjmp resume", "step resume",
 381                               "through sigtramp", "watchpoint scope",
 382                               "call dummy" };
 383   static char *bpdisp[] = {"delete", "delstop", "disable", "donttouch"};
 384   struct command_line *cmd;
 385   int bpnum;
 386   struct breakpoint *b;
 387   extern struct breakpoint *breakpoint_chain;
 388
 389   if (argc != 2)
 390     error ("wrong # args");
 391
 392   bpnum = atoi (argv[1]);
 393
 394   for (b = breakpoint_chain; b; b = b->next)
 395     if (b->number == bpnum)
 396       break;
 397
 398   if (!b || b->type != bp_breakpoint)
 399     error ("Breakpoint #%d does not exist", bpnum);
 400
 401   sal = find_pc_line (b->address, 0);
 402
 403   Tcl_DStringAppendElement (result_ptr, symtab_to_filename (sal.symtab));
 404   dsprintf_append_element (result_ptr, "%d", sal.line);
 405   dsprintf_append_element (result_ptr, "0x%lx", b->address);
 406   Tcl_DStringAppendElement (result_ptr, bptypes[b->type]);
 407   Tcl_DStringAppendElement (result_ptr, b->enable == enabled ? "1" : "0");
 408   Tcl_DStringAppendElement (result_ptr, bpdisp[b->disposition]);
 409   dsprintf_append_element (result_ptr, "%d", b->silent);
 410   dsprintf_append_element (result_ptr, "%d", b->ignore_count);
 411
 412   Tcl_DStringStartSublist (result_ptr);
 413   for (cmd = b->commands; cmd; cmd = cmd->next)
 414     Tcl_DStringAppendElement (result_ptr, cmd->line);
 415   Tcl_DStringEndSublist (result_ptr);
 416
 417   Tcl_DStringAppendElement (result_ptr, b->cond_string);
 418
 419   dsprintf_append_element (result_ptr, "%d", b->thread);
 420   dsprintf_append_element (result_ptr, "%d", b->hit_count);
 421
 422   return TCL_OK;
 423 }
 424
 425 static void
 426 breakpoint_notify(b, action)
 427      struct breakpoint *b;
 428      const char *action;
 429 {
 430   char buf[100];
 431   int v;
 432   struct symtab_and_line sal;
 433
 434   if (b->type != bp_breakpoint)
 435     return;
 436
 437   /* We ensure that ACTION contains no special Tcl characters, so we
 438      can do this.  */
 439   sal = find_pc_line (b->address, 0);
 440   sprintf (buf, "gdbtk_tcl_breakpoint %s %d 0x%lx %d {%s}", action, b->number,
 441            (long)b->address, sal.line, symtab_to_filename (sal.symtab));
 442
 443   v = Tcl_Eval (interp, buf);
 444
 445   if (v != TCL_OK)
 446     {
 447       gdbtk_fputs (interp->result, gdb_stdout);
 448       gdbtk_fputs ("\n", gdb_stdout);
 449     }
 450 }
 451
 452 static void
 453 gdbtk_create_breakpoint(b)
 454      struct breakpoint *b;
 455 {
 456   breakpoint_notify (b, "create");
 457 }
 458
 459 static void
 460 gdbtk_delete_breakpoint(b)
 461      struct breakpoint *b;
 462 {
 463   breakpoint_notify (b, "delete");
 464 }
 465
 466 static void
 467 gdbtk_modify_breakpoint(b)
 468      struct breakpoint *b;
 469 {
 470   breakpoint_notify (b, "modify");
 471 }
 472 \f
 473 /* This implements the TCL command `gdb_loc', which returns a list consisting
 474    of the source and line number associated with the current pc. */
 475
 476 static int
 477 gdb_loc (clientData, interp, argc, argv)
 478      ClientData clientData;
 479      Tcl_Interp *interp;
 480      int argc;
 481      char *argv[];
 482 {
 483   char *filename;
 484   struct symtab_and_line sal;
 485   char *funcname;
 486   CORE_ADDR pc;
 487
 488   if (argc == 1)
 489     {
 490       pc = selected_frame ? selected_frame->pc : stop_pc;
 491       sal = find_pc_line (pc, 0);
 492     }
 493   else if (argc == 2)
 494     {
 495       struct symtabs_and_lines sals;
 496       int nelts;
 497
 498       sals = decode_line_spec (argv[1], 1);
 499
 500       nelts = sals.nelts;
 501       sal = sals.sals[0];
 502       free (sals.sals);
 503
 504       if (sals.nelts != 1)
 505         error ("Ambiguous line spec");
 506
 507       pc = sal.pc;
 508     }
 509   else
 510     error ("wrong # args");
 511
 512   if (sal.symtab)
 513     Tcl_DStringAppendElement (result_ptr, sal.symtab->filename);
 514   else
 515     Tcl_DStringAppendElement (result_ptr, "");
 516
 517   find_pc_partial_function (pc, &funcname, NULL, NULL);
 518   Tcl_DStringAppendElement (result_ptr, funcname);
 519
 520   filename = symtab_to_filename (sal.symtab);
 521   Tcl_DStringAppendElement (result_ptr, filename);
 522
 523   dsprintf_append_element (result_ptr, "%d", sal.line); /* line number */
 524
 525   dsprintf_append_element (result_ptr, "0x%s", paddr_nz(pc)); /* PC in current frame */
 526
 527   dsprintf_append_element (result_ptr, "0x%s", paddr_nz(stop_pc)); /* Real PC */
 528
 529   return TCL_OK;
 530 }
 531 \f
 532 /* This implements the TCL command `gdb_eval'. */
 533
 534 static int
 535 gdb_eval (clientData, interp, argc, argv)
 536      ClientData clientData;
 537      Tcl_Interp *interp;
 538      int argc;
 539      char *argv[];
 540 {
 541   struct expression *expr;
 542   struct cleanup *old_chain;
 543   value_ptr val;
 544
 545   if (argc != 2)
 546     error ("wrong # args");
 547
 548   expr = parse_expression (argv[1]);
 549
 550   old_chain = make_cleanup (free_current_contents, &expr);
 551
 552   val = evaluate_expression (expr);
 553
 554   val_print (VALUE_TYPE (val), VALUE_CONTENTS (val), VALUE_ADDRESS (val),
 555              gdb_stdout, 0, 0, 0, 0);
 556
 557   do_cleanups (old_chain);
 558
 559   return TCL_OK;
 560 }
 561 \f
 562 /* This implements the TCL command `gdb_sourcelines', which returns a list of
 563    all of the lines containing executable code for the specified source file
 564    (ie: lines where you can put breakpoints). */
 565
 566 static int
 567 gdb_sourcelines (clientData, interp, argc, argv)
 568      ClientData clientData;
 569      Tcl_Interp *interp;
 570      int argc;
 571      char *argv[];
 572 {
 573   struct symtab *symtab;
 574   struct linetable_entry *le;
 575   int nlines;
 576
 577   if (argc != 2)
 578     error ("wrong # args");
 579
 580   symtab = lookup_symtab (argv[1]);
 581
 582   if (!symtab)
 583     error ("No such file");
 584
 585   /* If there's no linetable, or no entries, then we are done. */
 586
 587   if (!symtab->linetable
 588       || symtab->linetable->nitems == 0)
 589     {
 590       Tcl_DStringAppendElement (result_ptr, "");
 591       return TCL_OK;
 592     }
 593
 594   le = symtab->linetable->item;
 595   nlines = symtab->linetable->nitems;
 596
 597   for (;nlines > 0; nlines--, le++)
 598     {
 599       /* If the pc of this line is the same as the pc of the next line, then
 600          just skip it.  */
 601       if (nlines > 1
 602           && le->pc == (le + 1)->pc)
 603         continue;
 604
 605       dsprintf_append_element (result_ptr, "%d", le->line);
 606     }
 607
 608   return TCL_OK;
 609 }
 610 \f
 611 static int
 612 map_arg_registers (argc, argv, func, argp)
 613      int argc;
 614      char *argv[];
 615      void (*func) PARAMS ((int regnum, void *argp));
 616      void *argp;
 617 {
 618   int regnum;
 619
 620   /* Note that the test for a valid register must include checking the
 621      reg_names array because NUM_REGS may be allocated for the union of the
 622      register sets within a family of related processors.  In this case, the
 623      trailing entries of reg_names will change depending upon the particular
 624      processor being debugged.  */
 625
 626   if (argc == 0)                /* No args, just do all the regs */
 627     {
 628       for (regnum = 0;
 629            regnum < NUM_REGS
 630            && reg_names[regnum] != NULL
 631            && *reg_names[regnum] != '\000';
 632            regnum++)
 633         func (regnum, argp);
 634
 635       return TCL_OK;
 636     }
 637
 638   /* Else, list of register #s, just do listed regs */
 639   for (; argc > 0; argc--, argv++)
 640     {
 641       regnum = atoi (*argv);
 642
 643       if (regnum >= 0
 644           && regnum < NUM_REGS
 645           && reg_names[regnum] != NULL
 646           && *reg_names[regnum] != '\000')
 647         func (regnum, argp);
 648       else
 649         error ("bad register number");
 650     }
 651
 652   return TCL_OK;
 653 }
 654
 655 static void
 656 get_register_name (regnum, argp)
 657      int regnum;
 658      void *argp;                /* Ignored */
 659 {
 660   Tcl_DStringAppendElement (result_ptr, reg_names[regnum]);
 661 }
 662
 663 /* This implements the TCL command `gdb_regnames', which returns a list of
 664    all of the register names. */
 665
 666 static int
 667 gdb_regnames (clientData, interp, argc, argv)
 668      ClientData clientData;
 669      Tcl_Interp *interp;
 670      int argc;
 671      char *argv[];
 672 {
 673   argc--;
 674   argv++;
 675
 676   return map_arg_registers (argc, argv, get_register_name, NULL);
 677 }
 678
 679 #ifndef REGISTER_CONVERTIBLE
 680 #define REGISTER_CONVERTIBLE(x) (0 != 0)
 681 #endif
 682
 683 #ifndef REGISTER_CONVERT_TO_VIRTUAL
 684 #define REGISTER_CONVERT_TO_VIRTUAL(x, y, z, a)
 685 #endif
 686
 687 #ifndef INVALID_FLOAT
 688 #define INVALID_FLOAT(x, y) (0 != 0)
 689 #endif
 690
 691 static void
 692 get_register (regnum, fp)
 693      int regnum;
 694      void *fp;
 695 {
 696   char raw_buffer[MAX_REGISTER_RAW_SIZE];
 697   char virtual_buffer[MAX_REGISTER_VIRTUAL_SIZE];
 698   int format = (int)fp;
 699
 700   if (read_relative_register_raw_bytes (regnum, raw_buffer))
 701     {
 702       Tcl_DStringAppendElement (result_ptr, "Optimized out");
 703       return;
 704     }
 705
 706   /* Convert raw data to virtual format if necessary.  */
 707
 708   if (REGISTER_CONVERTIBLE (regnum))
 709     {
 710       REGISTER_CONVERT_TO_VIRTUAL (regnum, REGISTER_VIRTUAL_TYPE (regnum),
 711                                    raw_buffer, virtual_buffer);
 712     }
 713   else
 714     memcpy (virtual_buffer, raw_buffer, REGISTER_VIRTUAL_SIZE (regnum));
 715
 716   if (format == 'r')
 717     {
 718       int j;
 719       printf_filtered ("0x");
 720       for (j = 0; j < REGISTER_RAW_SIZE (regnum); j++)
 721         {
 722           register int idx = TARGET_BYTE_ORDER == BIG_ENDIAN ? j
 723             : REGISTER_RAW_SIZE (regnum) - 1 - j;
 724           printf_filtered ("%02x", (unsigned char)raw_buffer[idx]);
 725         }
 726     }
 727   else
 728     val_print (REGISTER_VIRTUAL_TYPE (regnum), virtual_buffer, 0,
 729                gdb_stdout, format, 1, 0, Val_pretty_default);
 730
 731   Tcl_DStringAppend (result_ptr, " ", -1);
 732 }
 733
 734 static int
 735 gdb_fetch_registers (clientData, interp, argc, argv)
 736      ClientData clientData;
 737      Tcl_Interp *interp;
 738      int argc;
 739      char *argv[];
 740 {
 741   int format;
 742
 743   if (argc < 2)
 744     error ("wrong # args");
 745
 746   argc--;
 747   argv++;
 748
 749   argc--;
 750   format = **argv++;
 751
 752   return map_arg_registers (argc, argv, get_register, (void *) format);
 753 }
 754
 755 /* This contains the previous values of the registers, since the last call to
 756    gdb_changed_register_list.  */
 757
 758 static char old_regs[REGISTER_BYTES];
 759
 760 static void
 761 register_changed_p (regnum, argp)
 762      int regnum;
 763      void *argp;                /* Ignored */
 764 {
 765   char raw_buffer[MAX_REGISTER_RAW_SIZE];
 766
 767   if (read_relative_register_raw_bytes (regnum, raw_buffer))
 768     return;
 769
 770   if (memcmp (&old_regs[REGISTER_BYTE (regnum)], raw_buffer,
 771               REGISTER_RAW_SIZE (regnum)) == 0)
 772     return;
 773
 774   /* Found a changed register.  Save new value and return its number. */
 775
 776   memcpy (&old_regs[REGISTER_BYTE (regnum)], raw_buffer,
 777           REGISTER_RAW_SIZE (regnum));
 778
 779   dsprintf_append_element (result_ptr, "%d", regnum);
 780 }
 781
 782 static int
 783 gdb_changed_register_list (clientData, interp, argc, argv)
 784      ClientData clientData;
 785      Tcl_Interp *interp;
 786      int argc;
 787      char *argv[];
 788 {
 789   argc--;
 790   argv++;
 791
 792   return map_arg_registers (argc, argv, register_changed_p, NULL);
 793 }
 794 \f
 795 /* This implements the TCL command `gdb_cmd', which sends its argument into
 796    the GDB command scanner.  */
 797
 798 static int
 799 gdb_cmd (clientData, interp, argc, argv)
 800      ClientData clientData;
 801      Tcl_Interp *interp;
 802      int argc;
 803      char *argv[];
 804 {
 805   if (argc != 2)
 806     error ("wrong # args");
 807
 808   if (running_now)
 809     return TCL_OK;
 810
 811   execute_command (argv[1], 1);
 812
 813   bpstat_do_actions (&stop_bpstat);
 814
 815   return TCL_OK;
 816 }
 817
 818 /* Client of call_wrapper - this routine performs the actual call to
 819    the client function. */
 820
 821 struct wrapped_call_args
 822 {
 823   Tcl_Interp *interp;
 824   Tcl_CmdProc *func;
 825   int argc;
 826   char **argv;
 827   int val;
 828 };
 829
 830 static int
 831 wrapped_call (args)
 832      struct wrapped_call_args *args;
 833 {
 834   args->val = (*args->func) (args->func, args->interp, args->argc, args->argv);
 835   return 1;
 836 }
 837
 838 /* This routine acts as a top-level for all GDB code called by tcl/Tk.  It
 839    handles cleanups, and calls to return_to_top_level (usually via error).
 840    This is necessary in order to prevent a longjmp out of the bowels of Tk,
 841    possibly leaving things in a bad state.  Since this routine can be called
 842    recursively, it needs to save and restore the contents of the jmp_buf as
 843    necessary.  */
 844
 845 static int
 846 call_wrapper (clientData, interp, argc, argv)
 847      ClientData clientData;
 848      Tcl_Interp *interp;
 849      int argc;
 850      char *argv[];
 851 {
 852   struct wrapped_call_args wrapped_args;
 853   Tcl_DString result, *old_result_ptr;
 854
 855   Tcl_DStringInit (&result);
 856   old_result_ptr = result_ptr;
 857   result_ptr = &result;
 858
 859   wrapped_args.func = (Tcl_CmdProc *)clientData;
 860   wrapped_args.interp = interp;
 861   wrapped_args.argc = argc;
 862   wrapped_args.argv = argv;
 863   wrapped_args.val = 0;
 864
 865   if (!catch_errors (wrapped_call, &wrapped_args, "", RETURN_MASK_ALL))
 866     {
 867       wrapped_args.val = TCL_ERROR;     /* Flag an error for TCL */
 868
 869       gdb_flush (gdb_stderr);   /* Flush error output */
 870
 871       gdb_flush (gdb_stdout);   /* Sometimes error output comes here as well */
 872
 873       /* In case of an error, we may need to force the GUI into idle
 874          mode because gdbtk_call_command may have bombed out while in
 875          the command routine.  */
 876
 877       running_now = 0;
 878       Tcl_Eval (interp, "gdbtk_tcl_idle");
 879     }
 880
 881   Tcl_DStringResult (interp, &result);
 882   result_ptr = old_result_ptr;
 883
 884   return wrapped_args.val;
 885 }
 886
 887 static int
 888 gdb_listfiles (clientData, interp, argc, argv)
 889      ClientData clientData;
 890      Tcl_Interp *interp;
 891      int argc;
 892      char *argv[];
 893 {
 894   struct objfile *objfile;
 895   struct partial_symtab *psymtab;
 896   struct symtab *symtab;
 897
 898   ALL_PSYMTABS (objfile, psymtab)
 899     Tcl_DStringAppendElement (result_ptr, psymtab->filename);
 900
 901   ALL_SYMTABS (objfile, symtab)
 902     Tcl_DStringAppendElement (result_ptr, symtab->filename);
 903
 904   return TCL_OK;
 905 }
 906
 907 static int
 908 gdb_stop (clientData, interp, argc, argv)
 909      ClientData clientData;
 910      Tcl_Interp *interp;
 911      int argc;
 912      char *argv[];
 913 {
 914   if (target_stop)
 915     target_stop ();
 916   else
 917     quit_flag = 1; /* hope something sees this */
 918
 919   return TCL_OK;
 920 }
 921 \f
 922 /* This implements the TCL command `gdb_disassemble'.  */
 923
 924 static int
 925 gdbtk_dis_asm_read_memory (memaddr, myaddr, len, info)
 926      bfd_vma memaddr;
 927      bfd_byte *myaddr;
 928      int len;
 929      disassemble_info *info;
 930 {
 931   extern struct target_ops exec_ops;
 932   int res;
 933
 934   errno = 0;
 935   res = xfer_memory (memaddr, myaddr, len, 0, &exec_ops);
 936
 937   if (res == len)
 938     return 0;
 939   else
 940     if (errno == 0)
 941       return EIO;
 942     else
 943       return errno;
 944 }
 945
 946 /* We need a different sort of line table from the normal one cuz we can't
 947    depend upon implicit line-end pc's for lines.  This is because of the
 948    reordering we are about to do.  */
 949
 950 struct my_line_entry {
 951   int line;
 952   CORE_ADDR start_pc;
 953   CORE_ADDR end_pc;
 954 };
 955
 956 static int
 957 compare_lines (mle1p, mle2p)
 958      const PTR mle1p;
 959      const PTR mle2p;
 960 {
 961   struct my_line_entry *mle1, *mle2;
 962   int val;
 963
 964   mle1 = (struct my_line_entry *) mle1p;
 965   mle2 = (struct my_line_entry *) mle2p;
 966
 967   val =  mle1->line - mle2->line;
 968
 969   if (val != 0)
 970     return val;
 971
 972   return mle1->start_pc - mle2->start_pc;
 973 }
 974
 975 static int
 976 gdb_disassemble (clientData, interp, argc, argv)
 977      ClientData clientData;
 978      Tcl_Interp *interp;
 979      int argc;
 980      char *argv[];
 981 {
 982   CORE_ADDR pc, low, high;
 983   int mixed_source_and_assembly;
 984   static disassemble_info di;
 985   static int di_initialized;
 986
 987   if (! di_initialized)
 988     {
 989       INIT_DISASSEMBLE_INFO_NO_ARCH (di, gdb_stdout,
 990                                      (fprintf_ftype) fprintf_unfiltered);
 991       di.flavour = bfd_target_unknown_flavour;
 992       di.memory_error_func = dis_asm_memory_error;
 993       di.print_address_func = dis_asm_print_address;
 994       di_initialized = 1;
 995     }
 996
 997   di.mach = tm_print_insn_info.mach;
 998   if (TARGET_BYTE_ORDER == BIG_ENDIAN)
 999     di.endian = BFD_ENDIAN_BIG;
1000   else
1001     di.endian = BFD_ENDIAN_LITTLE;
1002
1003   if (argc != 3 && argc != 4)
1004     error ("wrong # args");
1005
1006   if (strcmp (argv[1], "source") == 0)
1007     mixed_source_and_assembly = 1;
1008   else if (strcmp (argv[1], "nosource") == 0)
1009     mixed_source_and_assembly = 0;
1010   else
1011     error ("First arg must be 'source' or 'nosource'");
1012
1013   low = parse_and_eval_address (argv[2]);
1014
1015   if (argc == 3)
1016     {
1017       if (find_pc_partial_function (low, NULL, &low, &high) == 0)
1018         error ("No function contains specified address");
1019     }
1020   else
1021     high = parse_and_eval_address (argv[3]);
1022
1023   /* If disassemble_from_exec == -1, then we use the following heuristic to
1024      determine whether or not to do disassembly from target memory or from the
1025      exec file:
1026
1027      If we're debugging a local process, read target memory, instead of the
1028      exec file.  This makes disassembly of functions in shared libs work
1029      correctly.
1030
1031      Else, we're debugging a remote process, and should disassemble from the
1032      exec file for speed.  However, this is no good if the target modifies its
1033      code (for relocation, or whatever).
1034    */
1035
1036   if (disassemble_from_exec == -1)
1037     if (strcmp (target_shortname, "child") == 0
1038         || strcmp (target_shortname, "procfs") == 0
1039         || strcmp (target_shortname, "vxprocess") == 0)
1040       disassemble_from_exec = 0; /* It's a child process, read inferior mem */
1041     else
1042       disassemble_from_exec = 1; /* It's remote, read the exec file */
1043
1044   if (disassemble_from_exec)
1045     di.read_memory_func = gdbtk_dis_asm_read_memory;
1046   else
1047     di.read_memory_func = dis_asm_read_memory;
1048
1049   /* If just doing straight assembly, all we need to do is disassemble
1050      everything between low and high.  If doing mixed source/assembly, we've
1051      got a totally different path to follow.  */
1052
1053   if (mixed_source_and_assembly)
1054     {                           /* Come here for mixed source/assembly */
1055       /* The idea here is to present a source-O-centric view of a function to
1056          the user.  This means that things are presented in source order, with
1057          (possibly) out of order assembly immediately following.  */
1058       struct symtab *symtab;
1059       struct linetable_entry *le;
1060       int nlines;
1061       int newlines;
1062       struct my_line_entry *mle;
1063       struct symtab_and_line sal;
1064       int i;
1065       int out_of_order;
1066       int next_line;
1067
1068       symtab = find_pc_symtab (low); /* Assume symtab is valid for whole PC range */
1069
1070       if (!symtab)
1071         goto assembly_only;
1072
1073 /* First, convert the linetable to a bunch of my_line_entry's.  */
1074
1075       le = symtab->linetable->item;
1076       nlines = symtab->linetable->nitems;
1077
1078       if (nlines <= 0)
1079         goto assembly_only;
1080
1081       mle = (struct my_line_entry *) alloca (nlines * sizeof (struct my_line_entry));
1082
1083       out_of_order = 0;
1084
1085 /* Copy linetable entries for this function into our data structure, creating
1086    end_pc's and setting out_of_order as appropriate.  */
1087
1088 /* First, skip all the preceding functions.  */
1089
1090       for (i = 0; i < nlines - 1 && le[i].pc < low; i++) ;
1091
1092 /* Now, copy all entries before the end of this function.  */
1093
1094       newlines = 0;
1095       for (; i < nlines - 1 && le[i].pc < high; i++)
1096         {
1097           if (le[i].line == le[i + 1].line
1098               && le[i].pc == le[i + 1].pc)
1099             continue;           /* Ignore duplicates */
1100
1101           mle[newlines].line = le[i].line;
1102           if (le[i].line > le[i + 1].line)
1103             out_of_order = 1;
1104           mle[newlines].start_pc = le[i].pc;
1105           mle[newlines].end_pc = le[i + 1].pc;
1106           newlines++;
1107         }
1108
1109 /* If we're on the last line, and it's part of the function, then we need to
1110    get the end pc in a special way.  */
1111
1112       if (i == nlines - 1
1113           && le[i].pc < high)
1114         {
1115           mle[newlines].line = le[i].line;
1116           mle[newlines].start_pc = le[i].pc;
1117           sal = find_pc_line (le[i].pc, 0);
1118           mle[newlines].end_pc = sal.end;
1119           newlines++;
1120         }
1121
1122 /* Now, sort mle by line #s (and, then by addresses within lines). */
1123
1124       if (out_of_order)
1125         qsort (mle, newlines, sizeof (struct my_line_entry), compare_lines);
1126
1127 /* Now, for each line entry, emit the specified lines (unless they have been
1128    emitted before), followed by the assembly code for that line.  */
1129
1130       next_line = 0;            /* Force out first line */
1131       for (i = 0; i < newlines; i++)
1132         {
1133 /* Print out everything from next_line to the current line.  */
1134
1135           if (mle[i].line >= next_line)
1136             {
1137               if (next_line != 0)
1138                 print_source_lines (symtab, next_line, mle[i].line + 1, 0);
1139               else
1140                 print_source_lines (symtab, mle[i].line, mle[i].line + 1, 0);
1141
1142               next_line = mle[i].line + 1;
1143             }
1144
1145           for (pc = mle[i].start_pc; pc < mle[i].end_pc; )
1146             {
1147               QUIT;
1148               fputs_unfiltered ("    ", gdb_stdout);
1149               print_address (pc, gdb_stdout);
1150               fputs_unfiltered (":\t    ", gdb_stdout);
1151               pc += (*tm_print_insn) (pc, &di);
1152               fputs_unfiltered ("\n", gdb_stdout);
1153             }
1154         }
1155     }
1156   else
1157     {
1158 assembly_only:
1159       for (pc = low; pc < high; )
1160         {
1161           QUIT;
1162           fputs_unfiltered ("    ", gdb_stdout);
1163           print_address (pc, gdb_stdout);
1164           fputs_unfiltered (":\t    ", gdb_stdout);
1165           pc += (*tm_print_insn) (pc, &di);
1166           fputs_unfiltered ("\n", gdb_stdout);
1167         }
1168     }
1169
1170   gdb_flush (gdb_stdout);
1171
1172   return TCL_OK;
1173 }
1174 \f
1175 static void
1176 tk_command (cmd, from_tty)
1177      char *cmd;
1178      int from_tty;
1179 {
1180   int retval;
1181   char *result;
1182   struct cleanup *old_chain;
1183
1184   /* Catch case of no argument, since this will make the tcl interpreter dump core. */
1185   if (cmd == NULL)
1186     error_no_arg ("tcl command to interpret");
1187
1188   retval = Tcl_Eval (interp, cmd);
1189
1190   result = strdup (interp->result);
1191
1192   old_chain = make_cleanup (free, result);
1193
1194   if (retval != TCL_OK)
1195     error (result);
1196
1197   printf_unfiltered ("%s\n", result);
1198
1199   do_cleanups (old_chain);
1200 }
1201
1202 static void
1203 cleanup_init (ignored)
1204      int ignored;
1205 {
1206   if (interp != NULL)
1207     Tcl_DeleteInterp (interp);
1208   interp = NULL;
1209 }
1210
1211 /* Come here during long calculations to check for GUI events.  Usually invoked
1212    via the QUIT macro.  */
1213
1214 static void
1215 gdbtk_interactive ()
1216 {
1217   /* Tk_DoOneEvent (TK_DONT_WAIT|TK_IDLE_EVENTS); */
1218 }
1219
1220 /* Come here when there is activity on the X file descriptor. */
1221
1222 static void
1223 x_event (signo)
1224      int signo;
1225 {
1226   /* Process pending events */
1227
1228   while (Tcl_DoOneEvent (TCL_DONT_WAIT|TCL_ALL_EVENTS) != 0);
1229 }
1230
1231 static int
1232 gdbtk_wait (pid, ourstatus)
1233      int pid;
1234      struct target_waitstatus *ourstatus;
1235 {
1236   struct sigaction action;
1237   static sigset_t nullsigmask = {0};
1238
1239 #ifndef SA_RESTART
1240   /* Needed for SunOS 4.1.x */
1241 #define SA_RESTART 0
1242 #endif
1243
1244   action.sa_handler = x_event;
1245   action.sa_mask = nullsigmask;
1246   action.sa_flags = SA_RESTART;
1247 #ifndef WINNT
1248   sigaction(SIGIO, &action, NULL);
1249 #endif
1250
1251   pid = target_wait (pid, ourstatus);
1252
1253   action.sa_handler = SIG_IGN;
1254 #ifndef WINNT
1255   sigaction(SIGIO, &action, NULL);
1256 #endif
1257
1258   return pid;
1259 }
1260
1261 /* This is called from execute_command, and provides a wrapper around
1262    various command routines in a place where both protocol messages and
1263    user input both flow through.  Mostly this is used for indicating whether
1264    the target process is running or not.
1265 */
1266
1267 static void
1268 gdbtk_call_command (cmdblk, arg, from_tty)
1269      struct cmd_list_element *cmdblk;
1270      char *arg;
1271      int from_tty;
1272 {
1273   running_now = 0;
1274   if (cmdblk->class == class_run)
1275     {
1276       running_now = 1;
1277       Tcl_Eval (interp, "gdbtk_tcl_busy");
1278       (*cmdblk->function.cfunc)(arg, from_tty);
1279       running_now = 0;
1280       Tcl_Eval (interp, "gdbtk_tcl_idle");
1281     }
1282   else
1283     (*cmdblk->function.cfunc)(arg, from_tty);
1284 }
1285
1286 /* This function is called instead of gdb's internal command loop.  This is the
1287    last chance to do anything before entering the main Tk event loop. */
1288
1289 static void
1290 tk_command_loop ()
1291 {
1292   extern GDB_FILE *instream;
1293
1294   /* We no longer want to use stdin as the command input stream */
1295   instream = NULL;
1296   Tcl_Eval (interp, "gdbtk_tcl_preloop");
1297   Tk_MainLoop ();
1298 }
1299
1300 static void
1301 gdbtk_init ( argv0 )
1302      char *argv0;
1303 {
1304   struct cleanup *old_chain;
1305   char *lib, *gdbtk_lib, gdbtk_lib_tmp[1024],gdbtk_file[128];
1306   int i, found_main;
1307   struct sigaction action;
1308   static sigset_t nullsigmask = {0};
1309 #ifdef IDE
1310   struct ide_event_handle *h;
1311   const char *errmsg;
1312   char *libexecdir;
1313 #endif
1314
1315   /* If there is no DISPLAY environment variable, Tk_Init below will fail,
1316      causing gdb to abort.  If instead we simply return here, gdb will
1317      gracefully degrade to using the command line interface. */
1318
1319 #ifndef WINNT
1320   if (getenv ("DISPLAY") == NULL)
1321     return;
1322 #endif
1323
1324   old_chain = make_cleanup (cleanup_init, 0);
1325
1326   /* First init tcl and tk. */
1327   Tcl_FindExecutable (argv0);
1328   interp = Tcl_CreateInterp ();
1329
1330   if (!interp)
1331     error ("Tcl_CreateInterp failed");
1332
1333   if (Tcl_Init(interp) != TCL_OK)
1334     error ("Tcl_Init failed: %s", interp->result);
1335
1336   if (Tk_Init(interp) != TCL_OK)
1337     error ("Tk_Init failed: %s", interp->result);
1338
1339   if (Itcl_Init(interp) == TCL_ERROR)
1340     error ("Itcl_Init failed: %s", interp->result);
1341
1342   if (Tix_Init(interp) != TCL_OK)
1343     error ("Tix_Init failed: %s", interp->result);
1344
1345 #ifdef IDE
1346   /* Initialize the Paths variable.
1347   if (ide_initialize_paths (interp, "gdb") != TCL_OK)
1348     return (TCL_ERROR);
1349     */
1350   /* Find the directory where we expect to find idemanager.  We ignore
1351      errors since it doesn't really matter if this fails.  */
1352   libexecdir = Tcl_GetVar2 (interp, "Paths", "libexecdir", TCL_GLOBAL_ONLY);
1353
1354   IluTk_Init ();
1355
1356   h = ide_event_init_client (&errmsg, libexecdir);
1357   if (h == NULL)
1358     {
1359       Tcl_AppendResult (interp, "can't initialize event system: ", errmsg,
1360                         (char *) NULL);
1361       fprintf(stderr, "WARNING: ide_event_init_client failed: %s\n", interp->result);
1362     }
1363   else
1364     {
1365       if (ide_create_tclevent_command (interp, h) != TCL_OK)
1366         error ("ide_create_tclevent_command failed: %s", interp->result);
1367       if (ide_create_edit_command (interp, h) != TCL_OK)
1368         error ("ide_create_edit_command failed: %s", interp->result);
1369
1370       if (ide_create_property_command (interp, h) != TCL_OK)
1371         error ("ide_create_property_command failed: %s", interp->result);
1372
1373       /*
1374         if (ide_initialize (interp, "gdb") != TCL_OK)
1375         error ("ide_initialize failed: %s", interp->result);
1376       */
1377     }
1378   Tcl_SetVar (interp, "GDBTK_IDE", "1", 0);
1379 #else
1380   Tcl_SetVar (interp, "GDBTK_IDE", "0", 0);
1381 #endif /* IDE */
1382
1383   Tcl_CreateCommand (interp, "gdb_cmd", call_wrapper, gdb_cmd, NULL);
1384   Tcl_CreateCommand (interp, "gdb_loc", call_wrapper, gdb_loc, NULL);
1385   Tcl_CreateCommand (interp, "gdb_path_conv", call_wrapper, gdb_path_conv, NULL);
1386   Tcl_CreateCommand (interp, "gdb_sourcelines", call_wrapper, gdb_sourcelines,
1387                      NULL);
1388   Tcl_CreateCommand (interp, "gdb_listfiles", call_wrapper, gdb_listfiles,
1389                      NULL);
1390   Tcl_CreateCommand (interp, "gdb_stop", call_wrapper, gdb_stop, NULL);
1391   Tcl_CreateCommand (interp, "gdb_regnames", call_wrapper, gdb_regnames, NULL);
1392   Tcl_CreateCommand (interp, "gdb_fetch_registers", call_wrapper,
1393                      gdb_fetch_registers, NULL);
1394   Tcl_CreateCommand (interp, "gdb_changed_register_list", call_wrapper,
1395                      gdb_changed_register_list, NULL);
1396   Tcl_CreateCommand (interp, "gdb_disassemble", call_wrapper,
1397                      gdb_disassemble, NULL);
1398   Tcl_CreateCommand (interp, "gdb_eval", call_wrapper, gdb_eval, NULL);
1399   Tcl_CreateCommand (interp, "gdb_get_breakpoint_list", call_wrapper,
1400                      gdb_get_breakpoint_list, NULL);
1401   Tcl_CreateCommand (interp, "gdb_get_breakpoint_info", call_wrapper,
1402                      gdb_get_breakpoint_info, NULL);
1403
1404   command_loop_hook = tk_command_loop;
1405   print_frame_info_listing_hook =
1406     (void (*) PARAMS ((struct symtab *, int, int, int))) null_routine;
1407   query_hook = gdbtk_query;
1408   flush_hook = gdbtk_flush;
1409   create_breakpoint_hook = gdbtk_create_breakpoint;
1410   delete_breakpoint_hook = gdbtk_delete_breakpoint;
1411   modify_breakpoint_hook = gdbtk_modify_breakpoint;
1412   interactive_hook = gdbtk_interactive;
1413   target_wait_hook = gdbtk_wait;
1414   call_command_hook = gdbtk_call_command;
1415   readline_begin_hook = gdbtk_readline_begin;
1416   readline_hook = gdbtk_readline;
1417   readline_end_hook = gdbtk_readline_end;
1418
1419   /* Get the file descriptor for the X server */
1420
1421   x_fd = ConnectionNumber (Tk_Display (Tk_MainWindow (interp)));
1422
1423   /* Setup for I/O interrupts */
1424
1425   action.sa_mask = nullsigmask;
1426   action.sa_flags = 0;
1427   action.sa_handler = SIG_IGN;
1428 #ifndef WINNT
1429   sigaction(SIGIO, &action, NULL);
1430 #endif
1431
1432 #ifdef FIOASYNC
1433   i = 1;
1434   if (ioctl (x_fd, FIOASYNC, &i))
1435     perror_with_name ("gdbtk_init: ioctl FIOASYNC failed");
1436
1437 #ifdef SIOCSPGRP
1438   i = getpid();
1439   if (ioctl (x_fd, SIOCSPGRP, &i))
1440     perror_with_name ("gdbtk_init: ioctl SIOCSPGRP failed");
1441
1442 #else
1443 #ifdef F_SETOWN
1444   i = getpid();
1445   if (fcntl (x_fd, F_SETOWN, i))
1446     perror_with_name ("gdbtk_init: fcntl F_SETOWN failed");
1447 #endif  /* F_SETOWN */
1448 #endif  /* !SIOCSPGRP */
1449 #else
1450 #ifndef WINNT
1451   if (ioctl (x_fd,  I_SETSIG, S_INPUT|S_RDNORM) < 0)
1452     perror_with_name ("gdbtk_init: ioctl I_SETSIG failed");
1453 #endif
1454
1455 #endif /* ifndef FIOASYNC */
1456
1457   add_com ("tk", class_obscure, tk_command,
1458            "Send a command directly into tk.");
1459
1460   Tcl_LinkVar (interp, "disassemble-from-exec", (char *)&disassemble_from_exec,
1461                TCL_LINK_INT);
1462
1463   /* find the gdb tcl library and source main.tcl */
1464
1465   gdbtk_lib = getenv ("GDBTK_LIBRARY");
1466   if (!gdbtk_lib)
1467     if (access ("gdbtcl/main.tcl", R_OK) == 0)
1468       gdbtk_lib = "gdbtcl";
1469     else
1470       gdbtk_lib = GDBTK_LIBRARY;
1471
1472   strcpy (gdbtk_lib_tmp, gdbtk_lib);
1473   found_main = 0;
1474   /* see if GDBTK_LIBRARY is a path list */
1475   lib = strtok (gdbtk_lib_tmp, GDBTK_PATH_SEP);
1476   do
1477     {
1478       if (Tcl_VarEval (interp, "lappend auto_path ", lib, NULL) != TCL_OK)
1479         {
1480           fputs_unfiltered (Tcl_GetVar (interp, "errorInfo", 0), gdb_stderr);
1481           error ("");
1482         }
1483       if (!found_main)
1484         {
1485           strcpy (gdbtk_file, lib);
1486           strcat (gdbtk_file, "/main.tcl");
1487           if (access (gdbtk_file, R_OK) == 0)
1488             {
1489               found_main++;
1490               Tcl_SetVar (interp, "GDBTK_LIBRARY", lib, 0);
1491             }
1492         }
1493      }
1494   while ((lib = strtok (NULL, ":")) != NULL);
1495
1496   if (!found_main)
1497     {
1498       fputs_unfiltered_hook = NULL; /* Force errors to stdout/stderr */
1499       if (getenv("GDBTK_LIBRARY"))
1500         {
1501           fprintf_unfiltered (stderr, "Unable to find main.tcl in %s\n",getenv("GDBTK_LIBRARY"));
1502           fprintf_unfiltered (stderr,
1503                               "Please set GDBTK_LIBRARY to a path that includes the GDB tcl files.\n");
1504         }
1505       else
1506         {
1507           fprintf_unfiltered (stderr, "Unable to find main.tcl in %s\n", GDBTK_LIBRARY);
1508           fprintf_unfiltered (stderr, "You might want to set GDBTK_LIBRARY\n");
1509         }
1510       error("");
1511     }
1512
1513 /* Defer setup of fputs_unfiltered_hook to near the end so that error messages
1514    prior to this point go to stdout/stderr.  */
1515
1516   fputs_unfiltered_hook = gdbtk_fputs;
1517
1518   if (Tcl_EvalFile (interp, gdbtk_file) != TCL_OK)
1519     {
1520       fputs_unfiltered_hook = NULL; /* Force errors to stdout/stderr */
1521
1522       fprintf_unfiltered (stderr, "%s:%d: %s\n", gdbtk_file,
1523                           interp->errorLine, interp->result);
1524
1525       fputs_unfiltered ("Stack trace:\n", gdb_stderr);
1526       fputs_unfiltered (Tcl_GetVar (interp, "errorInfo", 0), gdb_stderr);
1527       error ("");
1528     }
1529
1530   discard_cleanups (old_chain);
1531 }
1532
1533 /* Come here during initialize_all_files () */
1534
1535 void
1536 _initialize_gdbtk ()
1537 {
1538   if (use_windows)
1539     {
1540       /* Tell the rest of the world that Gdbtk is now set up. */
1541
1542       init_ui_hook = gdbtk_init;
1543     }
1544 }