gdb/gdbtk.c

   1 /* Tcl/Tk interface routines.
   2    Copyright 1994, 1995 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., 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       struct my_line_entry *mle;
 854       struct symtab_and_line sal;
 855       int i;
 856       int out_of_order;
 857       int current_line;
 858
 859       symtab = find_pc_symtab (low); /* Assume symtab is valid for whole PC range */
 860
 861       if (!symtab)
 862         goto assembly_only;
 863
 864 /* First, convert the linetable to a bunch of my_line_entry's.  */
 865
 866       le = symtab->linetable->item;
 867       nlines = symtab->linetable->nitems;
 868
 869       if (nlines <= 0)
 870         goto assembly_only;
 871
 872       mle = (struct my_line_entry *) alloca (nlines * sizeof (struct my_line_entry));
 873
 874       out_of_order = 0;
 875
 876       for (i = 0; i < nlines - 1; i++)
 877         {
 878           mle[i].line = le[i].line;
 879           if (le[i].line > le[i + 1].line)
 880             out_of_order = 1;
 881           mle[i].start_pc = le[i].pc;
 882           mle[i].end_pc = le[i + 1].pc;
 883         }
 884
 885       mle[i].line = le[i].line;
 886       mle[i].start_pc = le[i].pc;
 887       sal = find_pc_line (le[i].pc, 0);
 888       mle[i].end_pc = sal.end;
 889
 890 /* Now, sort mle by line #s (and, then by addresses within lines). */
 891
 892       if (out_of_order)
 893         qsort (mle, nlines, sizeof (struct my_line_entry), compare_lines);
 894
 895 /* Scan forward until we find the start of the function.  */
 896
 897       for (i = 0; i < nlines; i++)
 898         if (mle[i].start_pc >= low)
 899           break;
 900
 901 /* Now, for each line entry, emit the specified lines (unless they have been
 902    emitted before), followed by the assembly code for that line.  */
 903
 904       current_line = 0;         /* Force out first line */
 905       for (;i < nlines && mle[i].start_pc < high; i++)
 906         {
 907           if (mle[i].line > current_line)
 908             {
 909               if (i == nlines - 1)
 910                 print_source_lines (symtab, mle[i].line, INT_MAX, 0);
 911               else
 912                 print_source_lines (symtab, mle[i].line, mle[i + 1].line, 0);
 913               current_line = mle[i].line;
 914             }
 915           for (pc = mle[i].start_pc; pc < mle[i].end_pc; )
 916             {
 917               QUIT;
 918               fputs_unfiltered ("    ", gdb_stdout);
 919               print_address (pc, gdb_stdout);
 920               fputs_unfiltered (":\t    ", gdb_stdout);
 921               pc += print_insn (pc, gdb_stdout);
 922               fputs_unfiltered ("\n", gdb_stdout);
 923             }
 924         }
 925     }
 926   else
 927     {
 928 assembly_only:
 929       for (pc = low; pc < high; )
 930         {
 931           QUIT;
 932           fputs_unfiltered ("    ", gdb_stdout);
 933           print_address (pc, gdb_stdout);
 934           fputs_unfiltered (":\t    ", gdb_stdout);
 935           pc += print_insn (pc, gdb_stdout);
 936           fputs_unfiltered ("\n", gdb_stdout);
 937         }
 938     }
 939
 940   dis_asm_read_memory_hook = 0;
 941
 942   gdb_flush (gdb_stdout);
 943
 944   return TCL_OK;
 945 }
 946 \f
 947 static void
 948 tk_command (cmd, from_tty)
 949      char *cmd;
 950      int from_tty;
 951 {
 952   int retval;
 953   char *result;
 954   struct cleanup *old_chain;
 955
 956   retval = Tcl_Eval (interp, cmd);
 957
 958   result = strdup (interp->result);
 959
 960   old_chain = make_cleanup (free, result);
 961
 962   if (retval != TCL_OK)
 963     error (result);
 964
 965   printf_unfiltered ("%s\n", result);
 966
 967   do_cleanups (old_chain);
 968 }
 969
 970 static void
 971 cleanup_init (ignored)
 972      int ignored;
 973 {
 974   if (mainWindow != NULL)
 975     Tk_DestroyWindow (mainWindow);
 976   mainWindow = NULL;
 977
 978   if (interp != NULL)
 979     Tcl_DeleteInterp (interp);
 980   interp = NULL;
 981 }
 982
 983 /* Come here during long calculations to check for GUI events.  Usually invoked
 984    via the QUIT macro.  */
 985
 986 static void
 987 gdbtk_interactive ()
 988 {
 989   /* Tk_DoOneEvent (TK_DONT_WAIT|TK_IDLE_EVENTS); */
 990 }
 991
 992 /* Come here when there is activity on the X file descriptor. */
 993
 994 static void
 995 x_event (signo)
 996      int signo;
 997 {
 998   /* Process pending events */
 999
1000   while (Tk_DoOneEvent (TK_DONT_WAIT|TK_ALL_EVENTS) != 0);
1001 }
1002
1003 static int
1004 gdbtk_wait (pid, ourstatus)
1005      int pid;
1006      struct target_waitstatus *ourstatus;
1007 {
1008   struct sigaction action;
1009   static sigset_t nullsigmask = {0};
1010
1011 #ifndef SA_RESTART
1012   /* Needed for SunOS 4.1.x */
1013 #define SA_RESTART 0
1014 #endif
1015
1016   action.sa_handler = x_event;
1017   action.sa_mask = nullsigmask;
1018   action.sa_flags = SA_RESTART;
1019   sigaction(SIGIO, &action, NULL);
1020
1021   pid = target_wait (pid, ourstatus);
1022
1023   action.sa_handler = SIG_IGN;
1024   sigaction(SIGIO, &action, NULL);
1025
1026   return pid;
1027 }
1028
1029 /* This is called from execute_command, and provides a wrapper around
1030    various command routines in a place where both protocol messages and
1031    user input both flow through.  Mostly this is used for indicating whether
1032    the target process is running or not.
1033 */
1034
1035 static void
1036 gdbtk_call_command (cmdblk, arg, from_tty)
1037      struct cmd_list_element *cmdblk;
1038      char *arg;
1039      int from_tty;
1040 {
1041   if (cmdblk->class == class_run)
1042     {
1043       Tcl_VarEval (interp, "gdbtk_tcl_busy", NULL);
1044       (*cmdblk->function.cfunc)(arg, from_tty);
1045       Tcl_VarEval (interp, "gdbtk_tcl_idle", NULL);
1046     }
1047   else
1048     (*cmdblk->function.cfunc)(arg, from_tty);
1049 }
1050
1051 static void
1052 gdbtk_init ()
1053 {
1054   struct cleanup *old_chain;
1055   char *gdbtk_filename;
1056   int i;
1057   struct sigaction action;
1058   static sigset_t nullsigmask = {0};
1059   extern struct cmd_list_element *setlist;
1060   extern struct cmd_list_element *showlist;
1061
1062   old_chain = make_cleanup (cleanup_init, 0);
1063
1064   /* First init tcl and tk. */
1065
1066   interp = Tcl_CreateInterp ();
1067
1068   if (!interp)
1069     error ("Tcl_CreateInterp failed");
1070
1071   Tcl_DStringInit (&stdout_buffer); /* Setup stdout buffer */
1072
1073   mainWindow = Tk_CreateMainWindow (interp, NULL, "gdb", "Gdb");
1074
1075   if (!mainWindow)
1076     return;                     /* DISPLAY probably not set */
1077
1078   if (Tcl_Init(interp) != TCL_OK)
1079     error ("Tcl_Init failed: %s", interp->result);
1080
1081   if (Tk_Init(interp) != TCL_OK)
1082     error ("Tk_Init failed: %s", interp->result);
1083
1084   Tcl_CreateCommand (interp, "gdb_cmd", call_wrapper, gdb_cmd, NULL);
1085   Tcl_CreateCommand (interp, "gdb_loc", call_wrapper, gdb_loc, NULL);
1086   Tcl_CreateCommand (interp, "gdb_sourcelines", call_wrapper, gdb_sourcelines,
1087                      NULL);
1088   Tcl_CreateCommand (interp, "gdb_listfiles", call_wrapper, gdb_listfiles,
1089                      NULL);
1090   Tcl_CreateCommand (interp, "gdb_stop", call_wrapper, gdb_stop, NULL);
1091   Tcl_CreateCommand (interp, "gdb_regnames", call_wrapper, gdb_regnames, NULL);
1092   Tcl_CreateCommand (interp, "gdb_fetch_registers", call_wrapper,
1093                      gdb_fetch_registers, NULL);
1094   Tcl_CreateCommand (interp, "gdb_changed_register_list", call_wrapper,
1095                      gdb_changed_register_list, NULL);
1096   Tcl_CreateCommand (interp, "gdb_disassemble", call_wrapper,
1097                      gdb_disassemble, NULL);
1098   Tcl_CreateCommand (interp, "gdb_eval", call_wrapper, gdb_eval, NULL);
1099
1100   command_loop_hook = Tk_MainLoop;
1101   print_frame_info_listing_hook = null_routine;
1102   query_hook = gdbtk_query;
1103   flush_hook = gdbtk_flush;
1104   create_breakpoint_hook = gdbtk_create_breakpoint;
1105   delete_breakpoint_hook = gdbtk_delete_breakpoint;
1106   enable_breakpoint_hook = gdbtk_enable_breakpoint;
1107   disable_breakpoint_hook = gdbtk_disable_breakpoint;
1108   interactive_hook = gdbtk_interactive;
1109   target_wait_hook = gdbtk_wait;
1110   call_command_hook = gdbtk_call_command;
1111
1112   /* Get the file descriptor for the X server */
1113
1114   x_fd = ConnectionNumber (Tk_Display (mainWindow));
1115
1116   /* Setup for I/O interrupts */
1117
1118   action.sa_mask = nullsigmask;
1119   action.sa_flags = 0;
1120   action.sa_handler = SIG_IGN;
1121   sigaction(SIGIO, &action, NULL);
1122
1123 #ifdef FIOASYNC
1124   i = 1;
1125   if (ioctl (x_fd, FIOASYNC, &i))
1126     perror_with_name ("gdbtk_init: ioctl FIOASYNC failed");
1127
1128   i = getpid();
1129   if (ioctl (x_fd, SIOCSPGRP, &i))
1130     perror_with_name ("gdbtk_init: ioctl SIOCSPGRP failed");
1131 #else
1132   if (ioctl (x_fd,  I_SETSIG, S_INPUT|S_RDNORM) < 0)
1133     perror_with_name ("gdbtk_init: ioctl I_SETSIG failed");
1134 #endif /* ifndef FIOASYNC */
1135
1136   add_com ("tk", class_obscure, tk_command,
1137            "Send a command directly into tk.");
1138
1139 #if 0
1140   add_show_from_set (add_set_cmd ("disassemble-from-exec", class_support,
1141                                   var_boolean, (char *)&disassemble_from_exec,
1142                                   "Set ", &setlist),
1143                      &showlist);
1144 #endif
1145
1146   Tcl_LinkVar (interp, "disassemble-from-exec", (char *)&disassemble_from_exec,
1147                TCL_LINK_INT);
1148
1149   /* Load up gdbtk.tcl after all the environment stuff has been setup.  */
1150
1151   gdbtk_filename = getenv ("GDBTK_FILENAME");
1152   if (!gdbtk_filename)
1153     if (access ("gdbtk.tcl", R_OK) == 0)
1154       gdbtk_filename = "gdbtk.tcl";
1155     else
1156       gdbtk_filename = GDBTK_FILENAME;
1157
1158 /* Defer setup of fputs_unfiltered_hook to near the end so that error messages
1159    prior to this point go to stdout/stderr.  */
1160
1161   fputs_unfiltered_hook = gdbtk_fputs;
1162
1163   if (Tcl_EvalFile (interp, gdbtk_filename) != TCL_OK)
1164     {
1165       fputs_unfiltered_hook = NULL; /* Force errors to stdout/stderr */
1166
1167       fprintf_unfiltered (stderr, "%s:%d: %s\n", gdbtk_filename,
1168                           interp->errorLine, interp->result);
1169       error ("Stack trace:\n%s", Tcl_GetVar (interp, "errorInfo", 0));
1170     }
1171
1172   discard_cleanups (old_chain);
1173 }
1174
1175 /* Come here during initialze_all_files () */
1176
1177 void
1178 _initialize_gdbtk ()
1179 {
1180   if (use_windows)
1181     {
1182       /* Tell the rest of the world that Gdbtk is now set up. */
1183
1184       init_ui_hook = gdbtk_init;
1185     }
1186 }