gdb/gdbtk.c

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