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