gdb/gdbtk.c

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