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