gdb/gdbtk.c

   1 /* TK interface routines.
   2    Copyright 1994 Free Software Foundation, Inc.
   3
   4 This file is part of GDB.
   5
   6 This program is free software; you can redistribute it and/or modify
   7 it under the terms of the GNU General Public License as published by
   8 the Free Software Foundation; either version 2 of the License, or
   9 (at your option) any later version.
  10
  11 This program is distributed in the hope that it will be useful,
  12 but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 GNU General Public License for more details.
  15
  16 You should have received a copy of the GNU General Public License
  17 along with this program; if not, write to the Free Software
  18 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.  */
  19
  20 #include "defs.h"
  21 #include "symtab.h"
  22 #include "inferior.h"
  23 #include "command.h"
  24 #include "bfd.h"
  25 #include "symfile.h"
  26 #include "objfiles.h"
  27 #include "target.h"
  28 #include <tcl.h>
  29 #include <tk.h>
  30 #include <varargs.h>
  31 #include <signal.h>
  32 #include <fcntl.h>
  33 #include <unistd.h>
  34 #include <setjmp.h>
  35 #include "top.h"
  36 #include <sys/ioctl.h>
  37 #include <string.h>
  38 #include "dis-asm.h"
  39
  40 #ifndef FIOASYNC
  41 #include <sys/stropts.h>
  42 #endif
  43
  44 /* Non-zero means that we're doing the gdbtk interface. */
  45 int gdbtk = 0;
  46
  47 /* Non-zero means we are reloading breakpoints, etc from the
  48    Gdbtk kernel, and we should suppress various messages */
  49 static int gdbtk_reloading = 0;
  50
  51 /* Handle for TCL interpreter */
  52 static Tcl_Interp *interp = NULL;
  53
  54 /* Handle for TK main window */
  55 static Tk_Window mainWindow = NULL;
  56
  57 static int x_fd;                /* X network socket */
  58
  59 /* This variable determines where memory used for disassembly is read from.
  60
  61    If > 0, then disassembly comes from the exec file rather than the target
  62    (which might be at the other end of a slow serial link).  If == 0 then
  63    disassembly comes from target.  If < 0 disassembly is automatically switched
  64    to the target if it's an inferior process, otherwise the exec file is
  65    used.
  66  */
  67
  68 static int disassemble_from_exec = -1;
  69
  70 static void
  71 null_routine(arg)
  72      int arg;
  73 {
  74 }
  75
  76 /* The following routines deal with stdout/stderr data, which is created by
  77    {f}printf_{un}filtered and friends.  gdbtk_fputs and gdbtk_flush are the
  78    lowest level of these routines and capture all output from the rest of GDB.
  79    Normally they present their data to tcl via callbacks to the following tcl
  80    routines:  gdbtk_tcl_fputs, gdbtk_tcl_fputs_error, and gdbtk_flush.  These
  81    in turn call tk routines to update the display.
  82
  83    Under some circumstances, you may want to collect the output so that it can
  84    be returned as the value of a tcl procedure.  This can be done by
  85    surrounding the output routines with calls to start_saving_output and
  86    finish_saving_output.  The saved data can then be retrieved with
  87    get_saved_output (but this must be done before the call to
  88    finish_saving_output).  */
  89
  90 /* Dynamic string header for stdout. */
  91
  92 static Tcl_DString stdout_buffer;
  93
  94 /* Use this to collect stdout output that will be returned as the result of a
  95    tcl command.  */
  96
  97 static int saving_output = 0;
  98
  99 static void
 100 start_saving_output ()
 101 {
 102   saving_output = 1;
 103 }
 104
 105 #define get_saved_output() (Tcl_DStringValue (&stdout_buffer))
 106
 107 static void
 108 finish_saving_output ()
 109 {
 110   if (!saving_output)
 111     return;
 112
 113   saving_output = 0;
 114
 115   Tcl_DStringFree (&stdout_buffer);
 116 }
 117 \f
 118 /* This routine redirects the output of fputs_unfiltered so that
 119    the user can see what's going on in his debugger window. */
 120
 121 static void
 122 flush_holdbuf ()
 123 {
 124   char *s, *argv[1];
 125
 126   /* We use Tcl_Merge to quote braces and funny characters as necessary. */
 127
 128   argv[0] = Tcl_DStringValue (&stdout_buffer);
 129   s = Tcl_Merge (1, argv);
 130
 131   Tcl_DStringFree (&stdout_buffer);
 132
 133   Tcl_VarEval (interp, "gdbtk_tcl_fputs ", s, NULL);
 134
 135   free (s);
 136 }
 137
 138 static void
 139 gdbtk_flush (stream)
 140      FILE *stream;
 141 {
 142   if (stream != gdb_stdout || saving_output)
 143     return;
 144
 145   /* Flush output from C to tcl land.  */
 146
 147   flush_holdbuf ();
 148
 149   /* Force immediate screen update */
 150
 151   Tcl_VarEval (interp, "gdbtk_tcl_flush", NULL);
 152 }
 153
 154 static void
 155 gdbtk_fputs (ptr, stream)
 156      const char *ptr;
 157      FILE *stream;
 158 {
 159   int len;
 160
 161   if (stream != gdb_stdout)
 162     {
 163       Tcl_VarEval (interp, "gdbtk_tcl_fputs_error ", "{", ptr, "}", NULL);
 164       return;
 165     }
 166
 167   Tcl_DStringAppend (&stdout_buffer, ptr, -1);
 168
 169   if (saving_output)
 170     return;
 171
 172   if (Tcl_DStringLength (&stdout_buffer) > 1000)
 173     flush_holdbuf ();
 174 }
 175
 176 static int
 177 gdbtk_query (args)
 178      va_list args;
 179 {
 180   char *query;
 181   char buf[200];
 182   long val;
 183
 184   query = va_arg (args, char *);
 185
 186   vsprintf(buf, query, args);
 187   Tcl_VarEval (interp, "gdbtk_tcl_query ", "{", buf, "}", NULL);
 188
 189   val = atol (interp->result);
 190   return val;
 191 }
 192 \f
 193 static void
 194 breakpoint_notify(b, action)
 195      struct breakpoint *b;
 196      const char *action;
 197 {
 198   struct symbol *sym;
 199   char bpnum[50], line[50], pc[50];
 200   struct symtab_and_line sal;
 201   char *filename;
 202   int v;
 203
 204   if (b->type != bp_breakpoint)
 205     return;
 206
 207   sal = find_pc_line (b->address, 0);
 208
 209   filename = symtab_to_filename (sal.symtab);
 210
 211   sprintf (bpnum, "%d", b->number);
 212   sprintf (line, "%d", sal.line);
 213   sprintf (pc, "0x%lx", b->address);
 214
 215   v = Tcl_VarEval (interp,
 216                    "gdbtk_tcl_breakpoint ",
 217                    action,
 218                    " ", bpnum,
 219                    " ", filename ? filename : "{}",
 220                    " ", line,
 221                    " ", pc,
 222                    NULL);
 223
 224   if (v != TCL_OK)
 225     {
 226       gdbtk_fputs (interp->result, gdb_stdout);
 227       gdbtk_fputs ("\n", gdb_stdout);
 228     }
 229 }
 230
 231 static void
 232 gdbtk_create_breakpoint(b)
 233      struct breakpoint *b;
 234 {
 235   breakpoint_notify(b, "create");
 236 }
 237
 238 static void
 239 gdbtk_delete_breakpoint(b)
 240      struct breakpoint *b;
 241 {
 242   breakpoint_notify(b, "delete");
 243 }
 244
 245 static void
 246 gdbtk_enable_breakpoint(b)
 247      struct breakpoint *b;
 248 {
 249   breakpoint_notify(b, "enable");
 250 }
 251
 252 static void
 253 gdbtk_disable_breakpoint(b)
 254      struct breakpoint *b;
 255 {
 256   breakpoint_notify(b, "disable");
 257 }
 258 \f
 259 /* This implements the TCL command `gdb_loc', which returns a list consisting
 260    of the source and line number associated with the current pc. */
 261
 262 static int
 263 gdb_loc (clientData, interp, argc, argv)
 264      ClientData clientData;
 265      Tcl_Interp *interp;
 266      int argc;
 267      char *argv[];
 268 {
 269   char *filename;
 270   char buf[100];
 271   struct symtab_and_line sal;
 272   char *funcname;
 273   CORE_ADDR pc;
 274
 275   if (argc == 1)
 276     {
 277       pc = selected_frame ? selected_frame->pc : stop_pc;
 278       sal = find_pc_line (pc, 0);
 279     }
 280   else if (argc == 2)
 281     {
 282       struct symtabs_and_lines sals;
 283       int nelts;
 284
 285       sals = decode_line_spec (argv[1], 1);
 286
 287       nelts = sals.nelts;
 288       sal = sals.sals[0];
 289       free (sals.sals);
 290
 291       if (sals.nelts != 1)
 292         {
 293           Tcl_SetResult (interp, "Ambiguous line spec", TCL_STATIC);
 294           return TCL_ERROR;
 295         }
 296
 297       pc = sal.pc;
 298     }
 299   else
 300     {
 301       Tcl_SetResult (interp, "wrong # args", TCL_STATIC);
 302       return TCL_ERROR;
 303     }
 304
 305   if (sal.symtab)
 306     Tcl_AppendElement (interp, sal.symtab->filename);
 307   else
 308     Tcl_AppendElement (interp, "");
 309
 310   find_pc_partial_function (pc, &funcname, NULL, NULL);
 311   Tcl_AppendElement (interp, funcname);
 312
 313   filename = symtab_to_filename (sal.symtab);
 314   Tcl_AppendElement (interp, filename);
 315
 316   sprintf (buf, "%d", sal.line);
 317   Tcl_AppendElement (interp, buf); /* line number */
 318
 319   sprintf (buf, "0x%lx", pc);
 320   Tcl_AppendElement (interp, buf); /* PC */
 321
 322   return TCL_OK;
 323 }
 324 \f
 325 /* This implements the TCL command `gdb_eval'. */
 326
 327 static int
 328 gdb_eval (clientData, interp, argc, argv)
 329      ClientData clientData;
 330      Tcl_Interp *interp;
 331      int argc;
 332      char *argv[];
 333 {
 334   struct expression *expr;
 335   struct cleanup *old_chain;
 336   value_ptr val;
 337
 338   if (argc != 2)
 339     {
 340       Tcl_SetResult (interp, "wrong # args", TCL_STATIC);
 341       return TCL_ERROR;
 342     }
 343
 344   expr = parse_expression (argv[1]);
 345
 346   old_chain = make_cleanup (free_current_contents, &expr);
 347
 348   val = evaluate_expression (expr);
 349
 350   start_saving_output ();       /* Start collecting stdout */
 351
 352   val_print (VALUE_TYPE (val), VALUE_CONTENTS (val), VALUE_ADDRESS (val),
 353              gdb_stdout, 0, 0, 0, 0);
 354 #if 0
 355   value_print (val, gdb_stdout, 0, 0);
 356 #endif
 357
 358   Tcl_AppendElement (interp, get_saved_output ());
 359
 360   finish_saving_output ();      /* Set stdout back to normal */
 361
 362   do_cleanups (old_chain);
 363
 364   return TCL_OK;
 365 }
 366 \f
 367 /* This implements the TCL command `gdb_sourcelines', which returns a list of
 368    all of the lines containing executable code for the specified source file
 369    (ie: lines where you can put breakpoints). */
 370
 371 static int
 372 gdb_sourcelines (clientData, interp, argc, argv)
 373      ClientData clientData;
 374      Tcl_Interp *interp;
 375      int argc;
 376      char *argv[];
 377 {
 378   struct symtab *symtab;
 379   struct linetable_entry *le;
 380   int nlines;
 381   char buf[100];
 382
 383   if (argc != 2)
 384     {
 385       Tcl_SetResult (interp, "wrong # args", TCL_STATIC);
 386       return TCL_ERROR;
 387     }
 388
 389   symtab = lookup_symtab (argv[1]);
 390
 391   if (!symtab)
 392     {
 393       Tcl_SetResult (interp, "No such file", TCL_STATIC);
 394       return TCL_ERROR;
 395     }
 396
 397   /* If there's no linetable, or no entries, then we are done. */
 398
 399   if (!symtab->linetable
 400       || symtab->linetable->nitems == 0)
 401     {
 402       Tcl_AppendElement (interp, "");
 403       return TCL_OK;
 404     }
 405
 406   le = symtab->linetable->item;
 407   nlines = symtab->linetable->nitems;
 408
 409   for (;nlines > 0; nlines--, le++)
 410     {
 411       /* If the pc of this line is the same as the pc of the next line, then
 412          just skip it.  */
 413       if (nlines > 1
 414           && le->pc == (le + 1)->pc)
 415         continue;
 416
 417       sprintf (buf, "%d", le->line);
 418       Tcl_AppendElement (interp, buf);
 419     }
 420
 421   return TCL_OK;
 422 }
 423 \f
 424 static int
 425 map_arg_registers (argc, argv, func, argp)
 426      int argc;
 427      char *argv[];
 428      int (*func) PARAMS ((int regnum, void *argp));
 429      void *argp;
 430 {
 431   int regnum;
 432
 433   /* Note that the test for a valid register must include checking the
 434      reg_names array because NUM_REGS may be allocated for the union of the
 435      register sets within a family of related processors.  In this case, the
 436      trailing entries of reg_names will change depending upon the particular
 437      processor being debugged.  */
 438
 439   if (argc == 0)                /* No args, just do all the regs */
 440     {
 441       for (regnum = 0;
 442            regnum < NUM_REGS
 443            && reg_names[regnum] != NULL
 444            && *reg_names[regnum] != '\000';
 445            regnum++)
 446         func (regnum, argp);
 447
 448       return TCL_OK;
 449     }
 450
 451   /* Else, list of register #s, just do listed regs */
 452   for (; argc > 0; argc--, argv++)
 453     {
 454       regnum = atoi (*argv);
 455
 456       if (regnum >= 0
 457           && regnum < NUM_REGS
 458           && reg_names[regnum] != NULL
 459           && *reg_names[regnum] != '\000')
 460         func (regnum, argp);
 461       else
 462         {
 463           Tcl_SetResult (interp, "bad register number", TCL_STATIC);
 464
 465           return TCL_ERROR;
 466         }
 467     }
 468
 469   return TCL_OK;
 470 }
 471
 472 static int
 473 get_register_name (regnum, argp)
 474      int regnum;
 475      void *argp;                /* Ignored */
 476 {
 477   Tcl_AppendElement (interp, reg_names[regnum]);
 478 }
 479
 480 /* This implements the TCL command `gdb_regnames', which returns a list of
 481    all of the register names. */
 482
 483 static int
 484 gdb_regnames (clientData, interp, argc, argv)
 485      ClientData clientData;
 486      Tcl_Interp *interp;
 487      int argc;
 488      char *argv[];
 489 {
 490   argc--;
 491   argv++;
 492
 493   return map_arg_registers (argc, argv, get_register_name, 0);
 494 }
 495
 496 #ifndef REGISTER_CONVERTIBLE
 497 #define REGISTER_CONVERTIBLE(x) (0 != 0)
 498 #endif
 499
 500 #ifndef REGISTER_CONVERT_TO_VIRTUAL
 501 #define REGISTER_CONVERT_TO_VIRTUAL(x, y, z, a)
 502 #endif
 503
 504 #ifndef INVALID_FLOAT
 505 #define INVALID_FLOAT(x, y) (0 != 0)
 506 #endif
 507
 508 static int
 509 get_register (regnum, fp)
 510      void *fp;
 511 {
 512   char raw_buffer[MAX_REGISTER_RAW_SIZE];
 513   char virtual_buffer[MAX_REGISTER_VIRTUAL_SIZE];
 514   int format = (int)fp;
 515
 516   if (read_relative_register_raw_bytes (regnum, raw_buffer))
 517     {
 518       Tcl_AppendElement (interp, "Optimized out");
 519       return;
 520     }
 521
 522   start_saving_output ();       /* Start collecting stdout */
 523
 524   /* Convert raw data to virtual format if necessary.  */
 525
 526   if (REGISTER_CONVERTIBLE (regnum))
 527     {
 528       REGISTER_CONVERT_TO_VIRTUAL (regnum, REGISTER_VIRTUAL_TYPE (regnum),
 529                                    raw_buffer, virtual_buffer);
 530     }
 531   else
 532     memcpy (virtual_buffer, raw_buffer, REGISTER_VIRTUAL_SIZE (regnum));
 533
 534   val_print (REGISTER_VIRTUAL_TYPE (regnum), virtual_buffer, 0,
 535              gdb_stdout, format, 1, 0, Val_pretty_default);
 536
 537   Tcl_AppendElement (interp, get_saved_output ());
 538
 539   finish_saving_output ();      /* Set stdout back to normal */
 540 }
 541
 542 static int
 543 gdb_fetch_registers (clientData, interp, argc, argv)
 544      ClientData clientData;
 545      Tcl_Interp *interp;
 546      int argc;
 547      char *argv[];
 548 {
 549   int format;
 550
 551   if (argc < 2)
 552     {
 553       Tcl_SetResult (interp, "wrong # args", TCL_STATIC);
 554       return TCL_ERROR;
 555     }
 556
 557   argc--;
 558   argv++;
 559
 560   argc--;
 561   format = **argv++;
 562
 563   return map_arg_registers (argc, argv, get_register, format);
 564 }
 565
 566 /* This contains the previous values of the registers, since the last call to
 567    gdb_changed_register_list.  */
 568
 569 static char old_regs[REGISTER_BYTES];
 570
 571 static int
 572 register_changed_p (regnum, argp)
 573      void *argp;                /* Ignored */
 574 {
 575   char raw_buffer[MAX_REGISTER_RAW_SIZE];
 576   char buf[100];
 577
 578   if (read_relative_register_raw_bytes (regnum, raw_buffer))
 579     return;
 580
 581   if (memcmp (&old_regs[REGISTER_BYTE (regnum)], raw_buffer,
 582               REGISTER_RAW_SIZE (regnum)) == 0)
 583     return;
 584
 585   /* Found a changed register.  Save new value and return it's number. */
 586
 587   memcpy (&old_regs[REGISTER_BYTE (regnum)], raw_buffer,
 588           REGISTER_RAW_SIZE (regnum));
 589
 590   sprintf (buf, "%d", regnum);
 591   Tcl_AppendElement (interp, buf);
 592 }
 593
 594 static int
 595 gdb_changed_register_list (clientData, interp, argc, argv)
 596      ClientData clientData;
 597      Tcl_Interp *interp;
 598      int argc;
 599      char *argv[];
 600 {
 601   int format;
 602
 603   argc--;
 604   argv++;
 605
 606   return map_arg_registers (argc, argv, register_changed_p, NULL);
 607 }
 608 \f
 609 /* This implements the TCL command `gdb_cmd', which sends it's argument into
 610    the GDB command scanner.  */
 611
 612 static int
 613 gdb_cmd (clientData, interp, argc, argv)
 614      ClientData clientData;
 615      Tcl_Interp *interp;
 616      int argc;
 617      char *argv[];
 618 {
 619   if (argc != 2)
 620     {
 621       Tcl_SetResult (interp, "wrong # args", TCL_STATIC);
 622       return TCL_ERROR;
 623     }
 624
 625   execute_command (argv[1], 1);
 626
 627   bpstat_do_actions (&stop_bpstat);
 628
 629   /* Drain all buffered command output */
 630
 631   gdb_flush (gdb_stdout);
 632
 633   return TCL_OK;
 634 }
 635
 636 /* This routine acts as a top-level for all GDB code called by tcl/Tk.  It
 637    handles cleanups, and calls to return_to_top_level (usually via error).
 638    This is necessary in order to prevent a longjmp out of the bowels of Tk,
 639    possibly leaving things in a bad state.  Since this routine can be called
 640    recursively, it needs to save and restore the contents of the jmp_buf as
 641    necessary.  */
 642
 643 static int
 644 call_wrapper (clientData, interp, argc, argv)
 645      ClientData clientData;
 646      Tcl_Interp *interp;
 647      int argc;
 648      char *argv[];
 649 {
 650   int val;
 651   struct cleanup *saved_cleanup_chain;
 652   Tcl_CmdProc *func;
 653   jmp_buf saved_error_return;
 654
 655   func = (Tcl_CmdProc *)clientData;
 656   memcpy (saved_error_return, error_return, sizeof (jmp_buf));
 657
 658   saved_cleanup_chain = save_cleanups ();
 659
 660   if (!setjmp (error_return))
 661     val = func (clientData, interp, argc, argv);
 662   else
 663     {
 664       val = TCL_ERROR;          /* Flag an error for TCL */
 665
 666       finish_saving_output ();  /* Restore stdout to normal */
 667
 668       dis_asm_read_memory_hook = 0; /* Restore disassembly hook */
 669
 670       gdb_flush (gdb_stderr);   /* Flush error output */
 671
 672       gdb_flush (gdb_stdout);   /* Sometimes error output comes here as well */
 673
 674 /* In case of an error, we may need to force the GUI into idle mode because
 675    gdbtk_call_command may have bombed out while in the command routine.  */
 676
 677       Tcl_VarEval (interp, "gdbtk_tcl_idle", NULL);
 678     }
 679
 680   do_cleanups (ALL_CLEANUPS);
 681
 682   restore_cleanups (saved_cleanup_chain);
 683
 684   memcpy (error_return, saved_error_return, sizeof (jmp_buf));
 685
 686   return val;
 687 }
 688
 689 static int
 690 gdb_listfiles (clientData, interp, argc, argv)
 691      ClientData clientData;
 692      Tcl_Interp *interp;
 693      int argc;
 694      char *argv[];
 695 {
 696   int val;
 697   struct objfile *objfile;
 698   struct partial_symtab *psymtab;
 699   struct symtab *symtab;
 700
 701   ALL_PSYMTABS (objfile, psymtab)
 702     Tcl_AppendElement (interp, psymtab->filename);
 703
 704   ALL_SYMTABS (objfile, symtab)
 705     Tcl_AppendElement (interp, symtab->filename);
 706
 707   return TCL_OK;
 708 }
 709
 710 static int
 711 gdb_stop (clientData, interp, argc, argv)
 712      ClientData clientData;
 713      Tcl_Interp *interp;
 714      int argc;
 715      char *argv[];
 716 {
 717   target_stop ();
 718
 719   return TCL_OK;
 720 }
 721 \f
 722 /* This implements the TCL command `gdb_disassemble'.  */
 723
 724 static int
 725 gdbtk_dis_asm_read_memory (memaddr, myaddr, len, info)
 726      bfd_vma memaddr;
 727      bfd_byte *myaddr;
 728      int len;
 729      disassemble_info *info;
 730 {
 731   extern struct target_ops exec_ops;
 732   int res;
 733
 734   errno = 0;
 735   res = xfer_memory (memaddr, myaddr, len, 0, &exec_ops);
 736
 737   if (res == len)
 738     return 0;
 739   else
 740     if (errno == 0)
 741       return EIO;
 742     else
 743       return errno;
 744 }
 745
 746 /* We need a different sort of line table from the normal one cuz we can't
 747    depend upon implicit line-end pc's for lines.  This is because of the
 748    reordering we are about to do.  */
 749
 750 struct my_line_entry {
 751   int line;
 752   CORE_ADDR start_pc;
 753   CORE_ADDR end_pc;
 754 };
 755
 756 static int
 757 compare_lines (mle1p, mle2p)
 758      const PTR mle1p;
 759      const PTR mle2p;
 760 {
 761   struct my_line_entry *mle1, *mle2;
 762   int val;
 763
 764   mle1 = (struct my_line_entry *) mle1p;
 765   mle2 = (struct my_line_entry *) mle2p;
 766
 767   val =  mle1->line - mle2->line;
 768
 769   if (val != 0)
 770     return val;
 771
 772   return mle1->start_pc - mle2->start_pc;
 773 }
 774
 775 static int
 776 gdb_disassemble (clientData, interp, argc, argv)
 777      ClientData clientData;
 778      Tcl_Interp *interp;
 779      int argc;
 780      char *argv[];
 781 {
 782   CORE_ADDR pc, low, high;
 783   int mixed_source_and_assembly;
 784
 785   if (argc != 3 && argc != 4)
 786     {
 787       Tcl_SetResult (interp, "wrong # args", TCL_STATIC);
 788       return TCL_ERROR;
 789     }
 790
 791   if (strcmp (argv[1], "source") == 0)
 792     mixed_source_and_assembly = 1;
 793   else if (strcmp (argv[1], "nosource") == 0)
 794     mixed_source_and_assembly = 0;
 795   else
 796     {
 797       Tcl_SetResult (interp, "First arg must be 'source' or 'nosource'",
 798                      TCL_STATIC);
 799       return TCL_ERROR;
 800     }
 801
 802   low = parse_and_eval_address (argv[2]);
 803
 804   if (argc == 3)
 805     {
 806       if (find_pc_partial_function (low, NULL, &low, &high) == 0)
 807         {
 808           Tcl_SetResult (interp, "No function contains specified address",
 809                          TCL_STATIC);
 810           return TCL_ERROR;
 811         }
 812     }
 813   else
 814     high = parse_and_eval_address (argv[3]);
 815
 816   /* If disassemble_from_exec == -1, then we use the following heuristic to
 817      determine whether or not to do disassembly from target memory or from the
 818      exec file:
 819
 820      If we're debugging a local process, read target memory, instead of the
 821      exec file.  This makes disassembly of functions in shared libs work
 822      correctly.
 823
 824      Else, we're debugging a remote process, and should disassemble from the
 825      exec file for speed.  However, this is no good if the target modifies it's
 826      code (for relocation, or whatever).
 827    */
 828
 829   if (disassemble_from_exec == -1)
 830     if (strcmp (target_shortname, "child") == 0
 831         || strcmp (target_shortname, "procfs") == 0)
 832       disassemble_from_exec = 0; /* It's a child process, read inferior mem */
 833     else
 834       disassemble_from_exec = 1; /* It's remote, read the exec file */
 835
 836   if (disassemble_from_exec)
 837     dis_asm_read_memory_hook = gdbtk_dis_asm_read_memory;
 838
 839   /* If just doing straight assembly, all we need to do is disassemble
 840      everything between low and high.  If doing mixed source/assembly, we've
 841      got a totally different path to follow.  */
 842
 843   if (mixed_source_and_assembly)
 844     {                           /* Come here for mixed source/assembly */
 845       /* The idea here is to present a source-O-centric view of a function to
 846          the user.  This means that things are presented in source order, with
 847          (possibly) out of order assembly immediately following.  */
 848       struct symtab *symtab;
 849       struct linetable_entry *le;
 850       int nlines;
 851       struct my_line_entry *mle;
 852       struct symtab_and_line sal;
 853       int i;
 854       int out_of_order;
 855       int current_line;
 856
 857       symtab = find_pc_symtab (low); /* Assume symtab is valid for whole PC range */
 858
 859       if (!symtab)
 860         goto assembly_only;
 861
 862 /* First, convert the linetable to a bunch of my_line_entry's.  */
 863
 864       le = symtab->linetable->item;
 865       nlines = symtab->linetable->nitems;
 866
 867       if (nlines <= 0)
 868         goto assembly_only;
 869
 870       mle = (struct my_line_entry *) alloca (nlines * sizeof (struct my_line_entry));
 871
 872       out_of_order = 0;
 873
 874       for (i = 0; i < nlines - 1; i++)
 875         {
 876           mle[i].line = le[i].line;
 877           if (le[i].line > le[i + 1].line)
 878             out_of_order = 1;
 879           mle[i].start_pc = le[i].pc;
 880           mle[i].end_pc = le[i + 1].pc;
 881         }
 882
 883       mle[i].line = le[i].line;
 884       mle[i].start_pc = le[i].pc;
 885       sal = find_pc_line (le[i].pc, 0);
 886       mle[i].end_pc = sal.end;
 887
 888 /* Now, sort mle by line #s (and, then by addresses within lines). */
 889
 890       if (out_of_order)
 891         qsort (mle, nlines, sizeof (struct my_line_entry), compare_lines);
 892
 893 /* Scan forward until we find the start of the function.  */
 894
 895       for (i = 0; i < nlines; i++)
 896         if (mle[i].start_pc >= low)
 897           break;
 898
 899 /* Now, for each line entry, emit the specified lines (unless they have been
 900    emitted before), followed by the assembly code for that line.  */
 901
 902       current_line = 0;         /* Force out first line */
 903       for (;i < nlines && mle[i].start_pc < high; i++)
 904         {
 905           if (mle[i].line > current_line)
 906             {
 907               if (i == nlines - 1)
 908                 print_source_lines (symtab, mle[i].line, INT_MAX, 0);
 909               else
 910                 print_source_lines (symtab, mle[i].line, mle[i + 1].line, 0);
 911               current_line = mle[i].line;
 912             }
 913           for (pc = mle[i].start_pc; pc < mle[i].end_pc; )
 914             {
 915               QUIT;
 916               fputs_unfiltered ("    ", gdb_stdout);
 917               print_address (pc, gdb_stdout);
 918               fputs_unfiltered (":\t    ", gdb_stdout);
 919               pc += print_insn (pc, gdb_stdout);
 920               fputs_unfiltered ("\n", gdb_stdout);
 921             }
 922         }
 923     }
 924   else
 925     {
 926 assembly_only:
 927       for (pc = low; pc < high; )
 928         {
 929           QUIT;
 930           fputs_unfiltered ("    ", gdb_stdout);
 931           print_address (pc, gdb_stdout);
 932           fputs_unfiltered (":\t    ", gdb_stdout);
 933           pc += print_insn (pc, gdb_stdout);
 934           fputs_unfiltered ("\n", gdb_stdout);
 935         }
 936     }
 937
 938   dis_asm_read_memory_hook = 0;
 939
 940   gdb_flush (gdb_stdout);
 941
 942   return TCL_OK;
 943 }
 944 \f
 945 static void
 946 tk_command (cmd, from_tty)
 947      char *cmd;
 948      int from_tty;
 949 {
 950   int retval;
 951   char *result;
 952   struct cleanup *old_chain;
 953
 954   retval = Tcl_Eval (interp, cmd);
 955
 956   result = strdup (interp->result);
 957
 958   old_chain = make_cleanup (free, result);
 959
 960   if (retval != TCL_OK)
 961     error (result);
 962
 963   printf_unfiltered ("%s\n", result);
 964
 965   do_cleanups (old_chain);
 966 }
 967
 968 static void
 969 cleanup_init (ignored)
 970      int ignored;
 971 {
 972   if (mainWindow != NULL)
 973     Tk_DestroyWindow (mainWindow);
 974   mainWindow = NULL;
 975
 976   if (interp != NULL)
 977     Tcl_DeleteInterp (interp);
 978   interp = NULL;
 979 }
 980
 981 /* Come here during long calculations to check for GUI events.  Usually invoked
 982    via the QUIT macro.  */
 983
 984 static void
 985 gdbtk_interactive ()
 986 {
 987   /* Tk_DoOneEvent (TK_DONT_WAIT|TK_IDLE_EVENTS); */
 988 }
 989
 990 /* Come here when there is activity on the X file descriptor. */
 991
 992 static void
 993 x_event (signo)
 994      int signo;
 995 {
 996   /* Process pending events */
 997
 998   while (Tk_DoOneEvent (TK_DONT_WAIT|TK_ALL_EVENTS) != 0);
 999 }
1000
1001 static int
1002 gdbtk_wait (pid, ourstatus)
1003      int pid;
1004      struct target_waitstatus *ourstatus;
1005 {
1006   struct sigaction action;
1007   static sigset_t nullsigmask = {0};
1008
1009 #ifndef SA_RESTART
1010   /* Needed for SunOS 4.1.x */
1011 #define SA_RESTART 0
1012 #endif
1013
1014   action.sa_handler = x_event;
1015   action.sa_mask = nullsigmask;
1016   action.sa_flags = SA_RESTART;
1017   sigaction(SIGIO, &action, NULL);
1018
1019   pid = target_wait (pid, ourstatus);
1020
1021   action.sa_handler = SIG_IGN;
1022   sigaction(SIGIO, &action, NULL);
1023
1024   return pid;
1025 }
1026
1027 /* This is called from execute_command, and provides a wrapper around
1028    various command routines in a place where both protocol messages and
1029    user input both flow through.  Mostly this is used for indicating whether
1030    the target process is running or not.
1031 */
1032
1033 static void
1034 gdbtk_call_command (cmdblk, arg, from_tty)
1035      struct cmd_list_element *cmdblk;
1036      char *arg;
1037      int from_tty;
1038 {
1039   if (cmdblk->class == class_run)
1040     {
1041       Tcl_VarEval (interp, "gdbtk_tcl_busy", NULL);
1042       (*cmdblk->function.cfunc)(arg, from_tty);
1043       Tcl_VarEval (interp, "gdbtk_tcl_idle", NULL);
1044     }
1045   else
1046     (*cmdblk->function.cfunc)(arg, from_tty);
1047 }
1048
1049 static void
1050 gdbtk_init ()
1051 {
1052   struct cleanup *old_chain;
1053   char *gdbtk_filename;
1054   int i;
1055   struct sigaction action;
1056   static sigset_t nullsigmask = {0};
1057   extern struct cmd_list_element *setlist;
1058   extern struct cmd_list_element *showlist;
1059
1060   old_chain = make_cleanup (cleanup_init, 0);
1061
1062   /* First init tcl and tk. */
1063
1064   interp = Tcl_CreateInterp ();
1065
1066   if (!interp)
1067     error ("Tcl_CreateInterp failed");
1068
1069   Tcl_DStringInit (&stdout_buffer); /* Setup stdout buffer */
1070
1071   mainWindow = Tk_CreateMainWindow (interp, NULL, "gdb", "Gdb");
1072
1073   if (!mainWindow)
1074     return;                     /* DISPLAY probably not set */
1075
1076   if (Tcl_Init(interp) != TCL_OK)
1077     error ("Tcl_Init failed: %s", interp->result);
1078
1079   if (Tk_Init(interp) != TCL_OK)
1080     error ("Tk_Init failed: %s", interp->result);
1081
1082   Tcl_CreateCommand (interp, "gdb_cmd", call_wrapper, gdb_cmd, NULL);
1083   Tcl_CreateCommand (interp, "gdb_loc", call_wrapper, gdb_loc, NULL);
1084   Tcl_CreateCommand (interp, "gdb_sourcelines", call_wrapper, gdb_sourcelines,
1085                      NULL);
1086   Tcl_CreateCommand (interp, "gdb_listfiles", call_wrapper, gdb_listfiles,
1087                      NULL);
1088   Tcl_CreateCommand (interp, "gdb_stop", call_wrapper, gdb_stop, NULL);
1089   Tcl_CreateCommand (interp, "gdb_regnames", call_wrapper, gdb_regnames, NULL);
1090   Tcl_CreateCommand (interp, "gdb_fetch_registers", call_wrapper,
1091                      gdb_fetch_registers, NULL);
1092   Tcl_CreateCommand (interp, "gdb_changed_register_list", call_wrapper,
1093                      gdb_changed_register_list, NULL);
1094   Tcl_CreateCommand (interp, "gdb_disassemble", call_wrapper,
1095                      gdb_disassemble, NULL);
1096   Tcl_CreateCommand (interp, "gdb_eval", call_wrapper, gdb_eval, NULL);
1097
1098   command_loop_hook = Tk_MainLoop;
1099   fputs_unfiltered_hook = gdbtk_fputs;
1100   print_frame_info_listing_hook = null_routine;
1101   query_hook = gdbtk_query;
1102   flush_hook = gdbtk_flush;
1103   create_breakpoint_hook = gdbtk_create_breakpoint;
1104   delete_breakpoint_hook = gdbtk_delete_breakpoint;
1105   enable_breakpoint_hook = gdbtk_enable_breakpoint;
1106   disable_breakpoint_hook = gdbtk_disable_breakpoint;
1107   interactive_hook = gdbtk_interactive;
1108   target_wait_hook = gdbtk_wait;
1109   call_command_hook = gdbtk_call_command;
1110
1111   /* Get the file descriptor for the X server */
1112
1113   x_fd = ConnectionNumber (Tk_Display (mainWindow));
1114
1115   /* Setup for I/O interrupts */
1116
1117   action.sa_mask = nullsigmask;
1118   action.sa_flags = 0;
1119   action.sa_handler = SIG_IGN;
1120   sigaction(SIGIO, &action, NULL);
1121
1122 #ifdef FIOASYNC
1123   i = 1;
1124   if (ioctl (x_fd, FIOASYNC, &i))
1125     perror_with_name ("gdbtk_init: ioctl FIOASYNC failed");
1126
1127   i = getpid();
1128   if (ioctl (x_fd, SIOCSPGRP, &i))
1129     perror_with_name ("gdbtk_init: ioctl SIOCSPGRP failed");
1130 #else
1131   if (ioctl (x_fd,  I_SETSIG, S_INPUT|S_RDNORM) < 0)
1132     perror_with_name ("gdbtk_init: ioctl I_SETSIG failed");
1133 #endif /* ifndef FIOASYNC */
1134
1135   add_com ("tk", class_obscure, tk_command,
1136            "Send a command directly into tk.");
1137
1138 #if 0
1139   add_show_from_set (add_set_cmd ("disassemble-from-exec", class_support,
1140                                   var_boolean, (char *)&disassemble_from_exec,
1141                                   "Set ", &setlist),
1142                      &showlist);
1143 #endif
1144
1145   Tcl_LinkVar (interp, "disassemble-from-exec", (char *)&disassemble_from_exec,
1146                TCL_LINK_INT);
1147
1148   /* Load up gdbtk.tcl after all the environment stuff has been setup.  */
1149
1150   gdbtk_filename = getenv ("GDBTK_FILENAME");
1151   if (!gdbtk_filename)
1152     if (access ("gdbtk.tcl", R_OK) == 0)
1153       gdbtk_filename = "gdbtk.tcl";
1154     else
1155       gdbtk_filename = GDBTK_FILENAME;
1156
1157   if (Tcl_EvalFile (interp, gdbtk_filename) != TCL_OK)
1158     error ("Failure reading %s: %s", gdbtk_filename, interp->result);
1159
1160   discard_cleanups (old_chain);
1161 }
1162
1163 /* Come here during initialze_all_files () */
1164
1165 void
1166 _initialize_gdbtk ()
1167 {
1168   if (use_windows)
1169     {
1170       /* Tell the rest of the world that Gdbtk is now set up. */
1171
1172       init_ui_hook = gdbtk_init;
1173     }
1174 }