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       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   static disassemble_info di = {
 785     (fprintf_ftype) fprintf_filtered, /* fprintf_func */
 786     gdb_stdout,                 /* stream */
 787     NULL,                       /* application_data */
 788     0,                          /* flags */
 789     NULL,                       /* private_data */
 790     NULL,                       /* read_memory_func */
 791     dis_asm_memory_error,       /* memory_error_func */
 792     dis_asm_print_address       /* print_address_func */
 793     };
 794
 795   if (argc != 3 && argc != 4)
 796     {
 797       Tcl_SetResult (interp, "wrong # args", TCL_STATIC);
 798       return TCL_ERROR;
 799     }
 800
 801   if (strcmp (argv[1], "source") == 0)
 802     mixed_source_and_assembly = 1;
 803   else if (strcmp (argv[1], "nosource") == 0)
 804     mixed_source_and_assembly = 0;
 805   else
 806     {
 807       Tcl_SetResult (interp, "First arg must be 'source' or 'nosource'",
 808                      TCL_STATIC);
 809       return TCL_ERROR;
 810     }
 811
 812   low = parse_and_eval_address (argv[2]);
 813
 814   if (argc == 3)
 815     {
 816       if (find_pc_partial_function (low, NULL, &low, &high) == 0)
 817         {
 818           Tcl_SetResult (interp, "No function contains specified address",
 819                          TCL_STATIC);
 820           return TCL_ERROR;
 821         }
 822     }
 823   else
 824     high = parse_and_eval_address (argv[3]);
 825
 826   /* If disassemble_from_exec == -1, then we use the following heuristic to
 827      determine whether or not to do disassembly from target memory or from the
 828      exec file:
 829
 830      If we're debugging a local process, read target memory, instead of the
 831      exec file.  This makes disassembly of functions in shared libs work
 832      correctly.
 833
 834      Else, we're debugging a remote process, and should disassemble from the
 835      exec file for speed.  However, this is no good if the target modifies it's
 836      code (for relocation, or whatever).
 837    */
 838
 839   if (disassemble_from_exec == -1)
 840     if (strcmp (target_shortname, "child") == 0
 841         || strcmp (target_shortname, "procfs") == 0)
 842       disassemble_from_exec = 0; /* It's a child process, read inferior mem */
 843     else
 844       disassemble_from_exec = 1; /* It's remote, read the exec file */
 845
 846   if (disassemble_from_exec)
 847     di.read_memory_func = gdbtk_dis_asm_read_memory;
 848   else
 849     di.read_memory_func = dis_asm_read_memory;
 850
 851   /* If just doing straight assembly, all we need to do is disassemble
 852      everything between low and high.  If doing mixed source/assembly, we've
 853      got a totally different path to follow.  */
 854
 855   if (mixed_source_and_assembly)
 856     {                           /* Come here for mixed source/assembly */
 857       /* The idea here is to present a source-O-centric view of a function to
 858          the user.  This means that things are presented in source order, with
 859          (possibly) out of order assembly immediately following.  */
 860       struct symtab *symtab;
 861       struct linetable_entry *le;
 862       int nlines;
 863       int newlines;
 864       struct my_line_entry *mle;
 865       struct symtab_and_line sal;
 866       int i;
 867       int out_of_order;
 868       int next_line;
 869
 870       symtab = find_pc_symtab (low); /* Assume symtab is valid for whole PC range */
 871
 872       if (!symtab)
 873         goto assembly_only;
 874
 875 /* First, convert the linetable to a bunch of my_line_entry's.  */
 876
 877       le = symtab->linetable->item;
 878       nlines = symtab->linetable->nitems;
 879
 880       if (nlines <= 0)
 881         goto assembly_only;
 882
 883       mle = (struct my_line_entry *) alloca (nlines * sizeof (struct my_line_entry));
 884
 885       out_of_order = 0;
 886
 887 /* Copy linetable entries for this function into our data structure, creating
 888    end_pc's and setting out_of_order as appropriate.  */
 889
 890 /* First, skip all the preceding functions.  */
 891
 892       for (i = 0; i < nlines - 1 && le[i].pc < low; i++) ;
 893
 894 /* Now, copy all entries before the end of this function.  */
 895
 896       newlines = 0;
 897       for (; i < nlines - 1 && le[i].pc < high; i++)
 898         {
 899           if (le[i].line == le[i + 1].line
 900               && le[i].pc == le[i + 1].pc)
 901             continue;           /* Ignore duplicates */
 902
 903           mle[newlines].line = le[i].line;
 904           if (le[i].line > le[i + 1].line)
 905             out_of_order = 1;
 906           mle[newlines].start_pc = le[i].pc;
 907           mle[newlines].end_pc = le[i + 1].pc;
 908           newlines++;
 909         }
 910
 911 /* If we're on the last line, and it's part of the function, then we need to
 912    get the end pc in a special way.  */
 913
 914       if (i == nlines - 1
 915           && le[i].pc < high)
 916         {
 917           mle[newlines].line = le[i].line;
 918           mle[newlines].start_pc = le[i].pc;
 919           sal = find_pc_line (le[i].pc, 0);
 920           mle[newlines].end_pc = sal.end;
 921           newlines++;
 922         }
 923
 924 /* Now, sort mle by line #s (and, then by addresses within lines). */
 925
 926       if (out_of_order)
 927         qsort (mle, newlines, sizeof (struct my_line_entry), compare_lines);
 928
 929 /* Now, for each line entry, emit the specified lines (unless they have been
 930    emitted before), followed by the assembly code for that line.  */
 931
 932       next_line = 0;            /* Force out first line */
 933       for (i = 0; i < newlines; i++)
 934         {
 935 /* Print out everything from next_line to the current line.  */
 936
 937           if (mle[i].line >= next_line)
 938             {
 939               if (next_line != 0)
 940                 print_source_lines (symtab, next_line, mle[i].line + 1, 0);
 941               else
 942                 print_source_lines (symtab, mle[i].line, mle[i].line + 1, 0);
 943
 944               next_line = mle[i].line + 1;
 945             }
 946
 947           for (pc = mle[i].start_pc; pc < mle[i].end_pc; )
 948             {
 949               QUIT;
 950               fputs_unfiltered ("    ", gdb_stdout);
 951               print_address (pc, gdb_stdout);
 952               fputs_unfiltered (":\t    ", gdb_stdout);
 953               pc += tm_print_insn (pc, &di);
 954               fputs_unfiltered ("\n", gdb_stdout);
 955             }
 956         }
 957     }
 958   else
 959     {
 960 assembly_only:
 961       for (pc = low; pc < high; )
 962         {
 963           QUIT;
 964           fputs_unfiltered ("    ", gdb_stdout);
 965           print_address (pc, gdb_stdout);
 966           fputs_unfiltered (":\t    ", gdb_stdout);
 967           pc += tm_print_insn (pc, &di);
 968           fputs_unfiltered ("\n", gdb_stdout);
 969         }
 970     }
 971
 972   gdb_flush (gdb_stdout);
 973
 974   return TCL_OK;
 975 }
 976 \f
 977 static void
 978 tk_command (cmd, from_tty)
 979      char *cmd;
 980      int from_tty;
 981 {
 982   int retval;
 983   char *result;
 984   struct cleanup *old_chain;
 985
 986   retval = Tcl_Eval (interp, cmd);
 987
 988   result = strdup (interp->result);
 989
 990   old_chain = make_cleanup (free, result);
 991
 992   if (retval != TCL_OK)
 993     error (result);
 994
 995   printf_unfiltered ("%s\n", result);
 996
 997   do_cleanups (old_chain);
 998 }
 999
1000 static void
1001 cleanup_init (ignored)
1002      int ignored;
1003 {
1004   if (mainWindow != NULL)
1005     Tk_DestroyWindow (mainWindow);
1006   mainWindow = NULL;
1007
1008   if (interp != NULL)
1009     Tcl_DeleteInterp (interp);
1010   interp = NULL;
1011 }
1012
1013 /* Come here during long calculations to check for GUI events.  Usually invoked
1014    via the QUIT macro.  */
1015
1016 static void
1017 gdbtk_interactive ()
1018 {
1019   /* Tk_DoOneEvent (TK_DONT_WAIT|TK_IDLE_EVENTS); */
1020 }
1021
1022 /* Come here when there is activity on the X file descriptor. */
1023
1024 static void
1025 x_event (signo)
1026      int signo;
1027 {
1028   /* Process pending events */
1029
1030   while (Tk_DoOneEvent (TK_DONT_WAIT|TK_ALL_EVENTS) != 0);
1031 }
1032
1033 static int
1034 gdbtk_wait (pid, ourstatus)
1035      int pid;
1036      struct target_waitstatus *ourstatus;
1037 {
1038   struct sigaction action;
1039   static sigset_t nullsigmask = {0};
1040
1041 #ifndef SA_RESTART
1042   /* Needed for SunOS 4.1.x */
1043 #define SA_RESTART 0
1044 #endif
1045
1046   action.sa_handler = x_event;
1047   action.sa_mask = nullsigmask;
1048   action.sa_flags = SA_RESTART;
1049   sigaction(SIGIO, &action, NULL);
1050
1051   pid = target_wait (pid, ourstatus);
1052
1053   action.sa_handler = SIG_IGN;
1054   sigaction(SIGIO, &action, NULL);
1055
1056   return pid;
1057 }
1058
1059 /* This is called from execute_command, and provides a wrapper around
1060    various command routines in a place where both protocol messages and
1061    user input both flow through.  Mostly this is used for indicating whether
1062    the target process is running or not.
1063 */
1064
1065 static void
1066 gdbtk_call_command (cmdblk, arg, from_tty)
1067      struct cmd_list_element *cmdblk;
1068      char *arg;
1069      int from_tty;
1070 {
1071   if (cmdblk->class == class_run)
1072     {
1073       Tcl_VarEval (interp, "gdbtk_tcl_busy", NULL);
1074       (*cmdblk->function.cfunc)(arg, from_tty);
1075       Tcl_VarEval (interp, "gdbtk_tcl_idle", NULL);
1076     }
1077   else
1078     (*cmdblk->function.cfunc)(arg, from_tty);
1079 }
1080
1081 static void
1082 gdbtk_init ()
1083 {
1084   struct cleanup *old_chain;
1085   char *gdbtk_filename;
1086   int i;
1087   struct sigaction action;
1088   static sigset_t nullsigmask = {0};
1089   extern struct cmd_list_element *setlist;
1090   extern struct cmd_list_element *showlist;
1091
1092   old_chain = make_cleanup (cleanup_init, 0);
1093
1094   /* First init tcl and tk. */
1095
1096   interp = Tcl_CreateInterp ();
1097
1098   if (!interp)
1099     error ("Tcl_CreateInterp failed");
1100
1101   Tcl_DStringInit (&stdout_buffer); /* Setup stdout buffer */
1102
1103   mainWindow = Tk_CreateMainWindow (interp, NULL, "gdb", "Gdb");
1104
1105   if (!mainWindow)
1106     return;                     /* DISPLAY probably not set */
1107
1108   if (Tcl_Init(interp) != TCL_OK)
1109     error ("Tcl_Init failed: %s", interp->result);
1110
1111   if (Tk_Init(interp) != TCL_OK)
1112     error ("Tk_Init failed: %s", interp->result);
1113
1114   Tcl_CreateCommand (interp, "gdb_cmd", call_wrapper, gdb_cmd, NULL);
1115   Tcl_CreateCommand (interp, "gdb_loc", call_wrapper, gdb_loc, NULL);
1116   Tcl_CreateCommand (interp, "gdb_sourcelines", call_wrapper, gdb_sourcelines,
1117                      NULL);
1118   Tcl_CreateCommand (interp, "gdb_listfiles", call_wrapper, gdb_listfiles,
1119                      NULL);
1120   Tcl_CreateCommand (interp, "gdb_stop", call_wrapper, gdb_stop, NULL);
1121   Tcl_CreateCommand (interp, "gdb_regnames", call_wrapper, gdb_regnames, NULL);
1122   Tcl_CreateCommand (interp, "gdb_fetch_registers", call_wrapper,
1123                      gdb_fetch_registers, NULL);
1124   Tcl_CreateCommand (interp, "gdb_changed_register_list", call_wrapper,
1125                      gdb_changed_register_list, NULL);
1126   Tcl_CreateCommand (interp, "gdb_disassemble", call_wrapper,
1127                      gdb_disassemble, NULL);
1128   Tcl_CreateCommand (interp, "gdb_eval", call_wrapper, gdb_eval, NULL);
1129
1130   command_loop_hook = Tk_MainLoop;
1131   print_frame_info_listing_hook = null_routine;
1132   query_hook = gdbtk_query;
1133   flush_hook = gdbtk_flush;
1134   create_breakpoint_hook = gdbtk_create_breakpoint;
1135   delete_breakpoint_hook = gdbtk_delete_breakpoint;
1136   enable_breakpoint_hook = gdbtk_enable_breakpoint;
1137   disable_breakpoint_hook = gdbtk_disable_breakpoint;
1138   interactive_hook = gdbtk_interactive;
1139   target_wait_hook = gdbtk_wait;
1140   call_command_hook = gdbtk_call_command;
1141
1142   /* Get the file descriptor for the X server */
1143
1144   x_fd = ConnectionNumber (Tk_Display (mainWindow));
1145
1146   /* Setup for I/O interrupts */
1147
1148   action.sa_mask = nullsigmask;
1149   action.sa_flags = 0;
1150   action.sa_handler = SIG_IGN;
1151   sigaction(SIGIO, &action, NULL);
1152
1153 #ifdef FIOASYNC
1154   i = 1;
1155   if (ioctl (x_fd, FIOASYNC, &i))
1156     perror_with_name ("gdbtk_init: ioctl FIOASYNC failed");
1157
1158   i = getpid();
1159   if (ioctl (x_fd, SIOCSPGRP, &i))
1160     perror_with_name ("gdbtk_init: ioctl SIOCSPGRP failed");
1161 #else
1162   if (ioctl (x_fd,  I_SETSIG, S_INPUT|S_RDNORM) < 0)
1163     perror_with_name ("gdbtk_init: ioctl I_SETSIG failed");
1164 #endif /* ifndef FIOASYNC */
1165
1166   add_com ("tk", class_obscure, tk_command,
1167            "Send a command directly into tk.");
1168
1169 #if 0
1170   add_show_from_set (add_set_cmd ("disassemble-from-exec", class_support,
1171                                   var_boolean, (char *)&disassemble_from_exec,
1172                                   "Set ", &setlist),
1173                      &showlist);
1174 #endif
1175
1176   Tcl_LinkVar (interp, "disassemble-from-exec", (char *)&disassemble_from_exec,
1177                TCL_LINK_INT);
1178
1179   /* Load up gdbtk.tcl after all the environment stuff has been setup.  */
1180
1181   gdbtk_filename = getenv ("GDBTK_FILENAME");
1182   if (!gdbtk_filename)
1183     if (access ("gdbtk.tcl", R_OK) == 0)
1184       gdbtk_filename = "gdbtk.tcl";
1185     else
1186       gdbtk_filename = GDBTK_FILENAME;
1187
1188 /* Defer setup of fputs_unfiltered_hook to near the end so that error messages
1189    prior to this point go to stdout/stderr.  */
1190
1191   fputs_unfiltered_hook = gdbtk_fputs;
1192
1193   if (Tcl_EvalFile (interp, gdbtk_filename) != TCL_OK)
1194     {
1195       char *err;
1196
1197       fputs_unfiltered_hook = NULL; /* Force errors to stdout/stderr */
1198
1199       fprintf_unfiltered (stderr, "%s:%d: %s\n", gdbtk_filename,
1200                           interp->errorLine, interp->result);
1201
1202       fputs_unfiltered ("Stack trace:\n", gdb_stderr);
1203       fputs_unfiltered (Tcl_GetVar (interp, "errorInfo", 0), gdb_stderr);
1204       error ("");
1205     }
1206
1207   discard_cleanups (old_chain);
1208 }
1209
1210 /* Come here during initialze_all_files () */
1211
1212 void
1213 _initialize_gdbtk ()
1214 {
1215   if (use_windows)
1216     {
1217       /* Tell the rest of the world that Gdbtk is now set up. */
1218
1219       init_ui_hook = gdbtk_init;
1220     }
1221 }