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   if (format == 'r')
 635     {
 636       int j;
 637       printf_filtered ("0x");
 638       for (j = 0; j < REGISTER_RAW_SIZE (regnum); j++)
 639         {
 640           register int idx = TARGET_BYTE_ORDER == BIG_ENDIAN ? j
 641             : REGISTER_RAW_SIZE (regnum) - 1 - j;
 642           printf_filtered ("%02x", (unsigned char)raw_buffer[idx]);
 643         }
 644     }
 645   else
 646     val_print (REGISTER_VIRTUAL_TYPE (regnum), virtual_buffer, 0,
 647                gdb_stdout, format, 1, 0, Val_pretty_default);
 648
 649   Tcl_DStringAppend (result_ptr, " ", -1);
 650 }
 651
 652 static int
 653 gdb_fetch_registers (clientData, interp, argc, argv)
 654      ClientData clientData;
 655      Tcl_Interp *interp;
 656      int argc;
 657      char *argv[];
 658 {
 659   int format;
 660
 661   if (argc < 2)
 662     error ("wrong # args");
 663
 664   argc--;
 665   argv++;
 666
 667   argc--;
 668   format = **argv++;
 669
 670   return map_arg_registers (argc, argv, get_register, format);
 671 }
 672
 673 /* This contains the previous values of the registers, since the last call to
 674    gdb_changed_register_list.  */
 675
 676 static char old_regs[REGISTER_BYTES];
 677
 678 static void
 679 register_changed_p (regnum, argp)
 680      int regnum;
 681      void *argp;                /* Ignored */
 682 {
 683   char raw_buffer[MAX_REGISTER_RAW_SIZE];
 684   char buf[100];
 685
 686   if (read_relative_register_raw_bytes (regnum, raw_buffer))
 687     return;
 688
 689   if (memcmp (&old_regs[REGISTER_BYTE (regnum)], raw_buffer,
 690               REGISTER_RAW_SIZE (regnum)) == 0)
 691     return;
 692
 693   /* Found a changed register.  Save new value and return its number. */
 694
 695   memcpy (&old_regs[REGISTER_BYTE (regnum)], raw_buffer,
 696           REGISTER_RAW_SIZE (regnum));
 697
 698   dsprintf_append_element (result_ptr, "%d", regnum);
 699 }
 700
 701 static int
 702 gdb_changed_register_list (clientData, interp, argc, argv)
 703      ClientData clientData;
 704      Tcl_Interp *interp;
 705      int argc;
 706      char *argv[];
 707 {
 708   argc--;
 709   argv++;
 710
 711   return map_arg_registers (argc, argv, register_changed_p, NULL);
 712 }
 713 \f
 714 /* This implements the TCL command `gdb_cmd', which sends its argument into
 715    the GDB command scanner.  */
 716
 717 static int
 718 gdb_cmd (clientData, interp, argc, argv)
 719      ClientData clientData;
 720      Tcl_Interp *interp;
 721      int argc;
 722      char *argv[];
 723 {
 724   if (argc != 2)
 725     error ("wrong # args");
 726
 727   if (running_now)
 728     return TCL_OK;
 729
 730   execute_command (argv[1], 1);
 731
 732   bpstat_do_actions (&stop_bpstat);
 733
 734   return TCL_OK;
 735 }
 736
 737 /* This routine acts as a top-level for all GDB code called by tcl/Tk.  It
 738    handles cleanups, and calls to return_to_top_level (usually via error).
 739    This is necessary in order to prevent a longjmp out of the bowels of Tk,
 740    possibly leaving things in a bad state.  Since this routine can be called
 741    recursively, it needs to save and restore the contents of the jmp_buf as
 742    necessary.  */
 743
 744 static int
 745 call_wrapper (clientData, interp, argc, argv)
 746      ClientData clientData;
 747      Tcl_Interp *interp;
 748      int argc;
 749      char *argv[];
 750 {
 751   int val;
 752   struct cleanup *saved_cleanup_chain;
 753   Tcl_CmdProc *func;
 754   jmp_buf saved_error_return;
 755   Tcl_DString result, *old_result_ptr;
 756
 757   Tcl_DStringInit (&result);
 758   old_result_ptr = result_ptr;
 759   result_ptr = &result;
 760
 761   func = (Tcl_CmdProc *)clientData;
 762   memcpy (saved_error_return, error_return, sizeof (jmp_buf));
 763
 764   saved_cleanup_chain = save_cleanups ();
 765
 766   if (!setjmp (error_return))
 767     val = func (clientData, interp, argc, argv);
 768   else
 769     {
 770       val = TCL_ERROR;          /* Flag an error for TCL */
 771
 772       gdb_flush (gdb_stderr);   /* Flush error output */
 773
 774       gdb_flush (gdb_stdout);   /* Sometimes error output comes here as well */
 775
 776       /* In case of an error, we may need to force the GUI into idle
 777          mode because gdbtk_call_command may have bombed out while in
 778          the command routine.  */
 779
 780       Tcl_Eval (interp, "gdbtk_tcl_idle");
 781     }
 782
 783   do_cleanups (ALL_CLEANUPS);
 784
 785   restore_cleanups (saved_cleanup_chain);
 786
 787   memcpy (error_return, saved_error_return, sizeof (jmp_buf));
 788
 789   Tcl_DStringResult (interp, &result);
 790   result_ptr = old_result_ptr;
 791
 792   return val;
 793 }
 794
 795 static int
 796 gdb_listfiles (clientData, interp, argc, argv)
 797      ClientData clientData;
 798      Tcl_Interp *interp;
 799      int argc;
 800      char *argv[];
 801 {
 802   struct objfile *objfile;
 803   struct partial_symtab *psymtab;
 804   struct symtab *symtab;
 805
 806   ALL_PSYMTABS (objfile, psymtab)
 807     Tcl_DStringAppendElement (result_ptr, psymtab->filename);
 808
 809   ALL_SYMTABS (objfile, symtab)
 810     Tcl_DStringAppendElement (result_ptr, symtab->filename);
 811
 812   return TCL_OK;
 813 }
 814
 815 static int
 816 gdb_stop (clientData, interp, argc, argv)
 817      ClientData clientData;
 818      Tcl_Interp *interp;
 819      int argc;
 820      char *argv[];
 821 {
 822   target_stop ();
 823
 824   return TCL_OK;
 825 }
 826 \f
 827 /* This implements the TCL command `gdb_disassemble'.  */
 828
 829 static int
 830 gdbtk_dis_asm_read_memory (memaddr, myaddr, len, info)
 831      bfd_vma memaddr;
 832      bfd_byte *myaddr;
 833      int len;
 834      disassemble_info *info;
 835 {
 836   extern struct target_ops exec_ops;
 837   int res;
 838
 839   errno = 0;
 840   res = xfer_memory (memaddr, myaddr, len, 0, &exec_ops);
 841
 842   if (res == len)
 843     return 0;
 844   else
 845     if (errno == 0)
 846       return EIO;
 847     else
 848       return errno;
 849 }
 850
 851 /* We need a different sort of line table from the normal one cuz we can't
 852    depend upon implicit line-end pc's for lines.  This is because of the
 853    reordering we are about to do.  */
 854
 855 struct my_line_entry {
 856   int line;
 857   CORE_ADDR start_pc;
 858   CORE_ADDR end_pc;
 859 };
 860
 861 static int
 862 compare_lines (mle1p, mle2p)
 863      const PTR mle1p;
 864      const PTR mle2p;
 865 {
 866   struct my_line_entry *mle1, *mle2;
 867   int val;
 868
 869   mle1 = (struct my_line_entry *) mle1p;
 870   mle2 = (struct my_line_entry *) mle2p;
 871
 872   val =  mle1->line - mle2->line;
 873
 874   if (val != 0)
 875     return val;
 876
 877   return mle1->start_pc - mle2->start_pc;
 878 }
 879
 880 static int
 881 gdb_disassemble (clientData, interp, argc, argv)
 882      ClientData clientData;
 883      Tcl_Interp *interp;
 884      int argc;
 885      char *argv[];
 886 {
 887   CORE_ADDR pc, low, high;
 888   int mixed_source_and_assembly;
 889   static disassemble_info di;
 890   static int di_initialized;
 891
 892   if (! di_initialized)
 893     {
 894       INIT_DISASSEMBLE_INFO_NO_ARCH (di, gdb_stdout,
 895                                      (fprintf_ftype) fprintf_unfiltered);
 896       di.memory_error_func = dis_asm_memory_error;
 897       di.print_address_func = dis_asm_print_address;
 898       di_initialized = 1;
 899     }
 900
 901   di.mach = tm_print_insn_info.mach;
 902   if (TARGET_BYTE_ORDER == BIG_ENDIAN)
 903     tm_print_insn_info.endian = BFD_ENDIAN_BIG;
 904   else
 905     tm_print_insn_info.endian = BFD_ENDIAN_LITTLE;
 906
 907   if (argc != 3 && argc != 4)
 908     error ("wrong # args");
 909
 910   if (strcmp (argv[1], "source") == 0)
 911     mixed_source_and_assembly = 1;
 912   else if (strcmp (argv[1], "nosource") == 0)
 913     mixed_source_and_assembly = 0;
 914   else
 915     error ("First arg must be 'source' or 'nosource'");
 916
 917   low = parse_and_eval_address (argv[2]);
 918
 919   if (argc == 3)
 920     {
 921       if (find_pc_partial_function (low, NULL, &low, &high) == 0)
 922         error ("No function contains specified address");
 923     }
 924   else
 925     high = parse_and_eval_address (argv[3]);
 926
 927   /* If disassemble_from_exec == -1, then we use the following heuristic to
 928      determine whether or not to do disassembly from target memory or from the
 929      exec file:
 930
 931      If we're debugging a local process, read target memory, instead of the
 932      exec file.  This makes disassembly of functions in shared libs work
 933      correctly.
 934
 935      Else, we're debugging a remote process, and should disassemble from the
 936      exec file for speed.  However, this is no good if the target modifies its
 937      code (for relocation, or whatever).
 938    */
 939
 940   if (disassemble_from_exec == -1)
 941     if (strcmp (target_shortname, "child") == 0
 942         || strcmp (target_shortname, "procfs") == 0
 943         || strcmp (target_shortname, "vxprocess") == 0)
 944       disassemble_from_exec = 0; /* It's a child process, read inferior mem */
 945     else
 946       disassemble_from_exec = 1; /* It's remote, read the exec file */
 947
 948   if (disassemble_from_exec)
 949     di.read_memory_func = gdbtk_dis_asm_read_memory;
 950   else
 951     di.read_memory_func = dis_asm_read_memory;
 952
 953   /* If just doing straight assembly, all we need to do is disassemble
 954      everything between low and high.  If doing mixed source/assembly, we've
 955      got a totally different path to follow.  */
 956
 957   if (mixed_source_and_assembly)
 958     {                           /* Come here for mixed source/assembly */
 959       /* The idea here is to present a source-O-centric view of a function to
 960          the user.  This means that things are presented in source order, with
 961          (possibly) out of order assembly immediately following.  */
 962       struct symtab *symtab;
 963       struct linetable_entry *le;
 964       int nlines;
 965       int newlines;
 966       struct my_line_entry *mle;
 967       struct symtab_and_line sal;
 968       int i;
 969       int out_of_order;
 970       int next_line;
 971
 972       symtab = find_pc_symtab (low); /* Assume symtab is valid for whole PC range */
 973
 974       if (!symtab)
 975         goto assembly_only;
 976
 977 /* First, convert the linetable to a bunch of my_line_entry's.  */
 978
 979       le = symtab->linetable->item;
 980       nlines = symtab->linetable->nitems;
 981
 982       if (nlines <= 0)
 983         goto assembly_only;
 984
 985       mle = (struct my_line_entry *) alloca (nlines * sizeof (struct my_line_entry));
 986
 987       out_of_order = 0;
 988
 989 /* Copy linetable entries for this function into our data structure, creating
 990    end_pc's and setting out_of_order as appropriate.  */
 991
 992 /* First, skip all the preceding functions.  */
 993
 994       for (i = 0; i < nlines - 1 && le[i].pc < low; i++) ;
 995
 996 /* Now, copy all entries before the end of this function.  */
 997
 998       newlines = 0;
 999       for (; i < nlines - 1 && le[i].pc < high; i++)
1000         {
1001           if (le[i].line == le[i + 1].line
1002               && le[i].pc == le[i + 1].pc)
1003             continue;           /* Ignore duplicates */
1004
1005           mle[newlines].line = le[i].line;
1006           if (le[i].line > le[i + 1].line)
1007             out_of_order = 1;
1008           mle[newlines].start_pc = le[i].pc;
1009           mle[newlines].end_pc = le[i + 1].pc;
1010           newlines++;
1011         }
1012
1013 /* If we're on the last line, and it's part of the function, then we need to
1014    get the end pc in a special way.  */
1015
1016       if (i == nlines - 1
1017           && le[i].pc < high)
1018         {
1019           mle[newlines].line = le[i].line;
1020           mle[newlines].start_pc = le[i].pc;
1021           sal = find_pc_line (le[i].pc, 0);
1022           mle[newlines].end_pc = sal.end;
1023           newlines++;
1024         }
1025
1026 /* Now, sort mle by line #s (and, then by addresses within lines). */
1027
1028       if (out_of_order)
1029         qsort (mle, newlines, sizeof (struct my_line_entry), compare_lines);
1030
1031 /* Now, for each line entry, emit the specified lines (unless they have been
1032    emitted before), followed by the assembly code for that line.  */
1033
1034       next_line = 0;            /* Force out first line */
1035       for (i = 0; i < newlines; i++)
1036         {
1037 /* Print out everything from next_line to the current line.  */
1038
1039           if (mle[i].line >= next_line)
1040             {
1041               if (next_line != 0)
1042                 print_source_lines (symtab, next_line, mle[i].line + 1, 0);
1043               else
1044                 print_source_lines (symtab, mle[i].line, mle[i].line + 1, 0);
1045
1046               next_line = mle[i].line + 1;
1047             }
1048
1049           for (pc = mle[i].start_pc; pc < mle[i].end_pc; )
1050             {
1051               QUIT;
1052               fputs_unfiltered ("    ", gdb_stdout);
1053               print_address (pc, gdb_stdout);
1054               fputs_unfiltered (":\t    ", gdb_stdout);
1055               pc += (*tm_print_insn) (pc, &di);
1056               fputs_unfiltered ("\n", gdb_stdout);
1057             }
1058         }
1059     }
1060   else
1061     {
1062 assembly_only:
1063       for (pc = low; pc < high; )
1064         {
1065           QUIT;
1066           fputs_unfiltered ("    ", gdb_stdout);
1067           print_address (pc, gdb_stdout);
1068           fputs_unfiltered (":\t    ", gdb_stdout);
1069           pc += (*tm_print_insn) (pc, &di);
1070           fputs_unfiltered ("\n", gdb_stdout);
1071         }
1072     }
1073
1074   gdb_flush (gdb_stdout);
1075
1076   return TCL_OK;
1077 }
1078 \f
1079 static void
1080 tk_command (cmd, from_tty)
1081      char *cmd;
1082      int from_tty;
1083 {
1084   int retval;
1085   char *result;
1086   struct cleanup *old_chain;
1087
1088   /* Catch case of no argument, since this will make the tcl interpreter dump core. */
1089   if (cmd == NULL)
1090     error_no_arg ("tcl command to interpret");
1091
1092   retval = Tcl_Eval (interp, cmd);
1093
1094   result = strdup (interp->result);
1095
1096   old_chain = make_cleanup (free, result);
1097
1098   if (retval != TCL_OK)
1099     error (result);
1100
1101   printf_unfiltered ("%s\n", result);
1102
1103   do_cleanups (old_chain);
1104 }
1105
1106 static void
1107 cleanup_init (ignored)
1108      int ignored;
1109 {
1110   if (mainWindow != NULL)
1111     Tk_DestroyWindow (mainWindow);
1112   mainWindow = NULL;
1113
1114   if (interp != NULL)
1115     Tcl_DeleteInterp (interp);
1116   interp = NULL;
1117 }
1118
1119 /* Come here during long calculations to check for GUI events.  Usually invoked
1120    via the QUIT macro.  */
1121
1122 static void
1123 gdbtk_interactive ()
1124 {
1125   /* Tk_DoOneEvent (TK_DONT_WAIT|TK_IDLE_EVENTS); */
1126 }
1127
1128 /* Come here when there is activity on the X file descriptor. */
1129
1130 static void
1131 x_event (signo)
1132      int signo;
1133 {
1134   /* Process pending events */
1135
1136   while (Tk_DoOneEvent (TK_DONT_WAIT|TK_ALL_EVENTS) != 0);
1137 }
1138
1139 static int
1140 gdbtk_wait (pid, ourstatus)
1141      int pid;
1142      struct target_waitstatus *ourstatus;
1143 {
1144   struct sigaction action;
1145   static sigset_t nullsigmask = {0};
1146
1147 #ifndef SA_RESTART
1148   /* Needed for SunOS 4.1.x */
1149 #define SA_RESTART 0
1150 #endif
1151
1152   action.sa_handler = x_event;
1153   action.sa_mask = nullsigmask;
1154   action.sa_flags = SA_RESTART;
1155   sigaction(SIGIO, &action, NULL);
1156
1157   pid = target_wait (pid, ourstatus);
1158
1159   action.sa_handler = SIG_IGN;
1160   sigaction(SIGIO, &action, NULL);
1161
1162   return pid;
1163 }
1164
1165 /* This is called from execute_command, and provides a wrapper around
1166    various command routines in a place where both protocol messages and
1167    user input both flow through.  Mostly this is used for indicating whether
1168    the target process is running or not.
1169 */
1170
1171 static void
1172 gdbtk_call_command (cmdblk, arg, from_tty)
1173      struct cmd_list_element *cmdblk;
1174      char *arg;
1175      int from_tty;
1176 {
1177   running_now = 0;
1178   if (cmdblk->class == class_run)
1179     {
1180       running_now = 1;
1181       Tcl_Eval (interp, "gdbtk_tcl_busy");
1182       (*cmdblk->function.cfunc)(arg, from_tty);
1183       Tcl_Eval (interp, "gdbtk_tcl_idle");
1184       running_now = 0;
1185     }
1186   else
1187     (*cmdblk->function.cfunc)(arg, from_tty);
1188 }
1189
1190 /* This function is called instead of gdb's internal command loop.  This is the
1191    last chance to do anything before entering the main Tk event loop. */
1192
1193 static void
1194 tk_command_loop ()
1195 {
1196   extern GDB_FILE *instream;
1197
1198   /* We no longer want to use stdin as the command input stream */
1199   instream = NULL;
1200   Tcl_Eval (interp, "gdbtk_tcl_preloop");
1201   Tk_MainLoop ();
1202 }
1203
1204 static void
1205 gdbtk_init ()
1206 {
1207   struct cleanup *old_chain;
1208   char *gdbtk_filename;
1209   int i;
1210   struct sigaction action;
1211   static sigset_t nullsigmask = {0};
1212
1213   old_chain = make_cleanup (cleanup_init, 0);
1214
1215   /* First init tcl and tk. */
1216
1217   interp = Tcl_CreateInterp ();
1218
1219   if (!interp)
1220     error ("Tcl_CreateInterp failed");
1221
1222   mainWindow = Tk_CreateMainWindow (interp, NULL, "gdb", "Gdb");
1223
1224   if (!mainWindow)
1225     return;                     /* DISPLAY probably not set */
1226
1227   if (Tcl_Init(interp) != TCL_OK)
1228     error ("Tcl_Init failed: %s", interp->result);
1229
1230   if (Tk_Init(interp) != TCL_OK)
1231     error ("Tk_Init failed: %s", interp->result);
1232
1233   Tcl_CreateCommand (interp, "gdb_cmd", call_wrapper, gdb_cmd, NULL);
1234   Tcl_CreateCommand (interp, "gdb_loc", call_wrapper, gdb_loc, NULL);
1235   Tcl_CreateCommand (interp, "gdb_sourcelines", call_wrapper, gdb_sourcelines,
1236                      NULL);
1237   Tcl_CreateCommand (interp, "gdb_listfiles", call_wrapper, gdb_listfiles,
1238                      NULL);
1239   Tcl_CreateCommand (interp, "gdb_stop", call_wrapper, gdb_stop, NULL);
1240   Tcl_CreateCommand (interp, "gdb_regnames", call_wrapper, gdb_regnames, NULL);
1241   Tcl_CreateCommand (interp, "gdb_fetch_registers", call_wrapper,
1242                      gdb_fetch_registers, NULL);
1243   Tcl_CreateCommand (interp, "gdb_changed_register_list", call_wrapper,
1244                      gdb_changed_register_list, NULL);
1245   Tcl_CreateCommand (interp, "gdb_disassemble", call_wrapper,
1246                      gdb_disassemble, NULL);
1247   Tcl_CreateCommand (interp, "gdb_eval", call_wrapper, gdb_eval, NULL);
1248   Tcl_CreateCommand (interp, "gdb_get_breakpoint_list", call_wrapper,
1249                      gdb_get_breakpoint_list, NULL);
1250   Tcl_CreateCommand (interp, "gdb_get_breakpoint_info", call_wrapper,
1251                      gdb_get_breakpoint_info, NULL);
1252
1253   command_loop_hook = tk_command_loop;
1254   print_frame_info_listing_hook = null_routine;
1255   query_hook = gdbtk_query;
1256   flush_hook = gdbtk_flush;
1257   create_breakpoint_hook = gdbtk_create_breakpoint;
1258   delete_breakpoint_hook = gdbtk_delete_breakpoint;
1259   modify_breakpoint_hook = gdbtk_modify_breakpoint;
1260   interactive_hook = gdbtk_interactive;
1261   target_wait_hook = gdbtk_wait;
1262   call_command_hook = gdbtk_call_command;
1263   readline_begin_hook = gdbtk_readline_begin;
1264   readline_hook = gdbtk_readline;
1265   readline_end_hook = gdbtk_readline_end;
1266
1267   /* Get the file descriptor for the X server */
1268
1269   x_fd = ConnectionNumber (Tk_Display (mainWindow));
1270
1271   /* Setup for I/O interrupts */
1272
1273   action.sa_mask = nullsigmask;
1274   action.sa_flags = 0;
1275   action.sa_handler = SIG_IGN;
1276   sigaction(SIGIO, &action, NULL);
1277
1278 #ifdef FIOASYNC
1279   i = 1;
1280   if (ioctl (x_fd, FIOASYNC, &i))
1281     perror_with_name ("gdbtk_init: ioctl FIOASYNC failed");
1282
1283 #ifdef SIOCSPGRP
1284   i = getpid();
1285   if (ioctl (x_fd, SIOCSPGRP, &i))
1286     perror_with_name ("gdbtk_init: ioctl SIOCSPGRP failed");
1287
1288 #else
1289 #ifdef F_SETOWN
1290   i = getpid();
1291   if (fcntl (x_fd, F_SETOWN, i))
1292     perror_with_name ("gdbtk_init: fcntl F_SETOWN failed");
1293 #endif  /* F_SETOWN */
1294 #endif  /* !SIOCSPGRP */
1295 #else
1296   if (ioctl (x_fd,  I_SETSIG, S_INPUT|S_RDNORM) < 0)
1297     perror_with_name ("gdbtk_init: ioctl I_SETSIG failed");
1298 #endif /* ifndef FIOASYNC */
1299
1300   add_com ("tk", class_obscure, tk_command,
1301            "Send a command directly into tk.");
1302
1303   Tcl_LinkVar (interp, "disassemble-from-exec", (char *)&disassemble_from_exec,
1304                TCL_LINK_INT);
1305
1306   /* Load up gdbtk.tcl after all the environment stuff has been setup.  */
1307
1308   gdbtk_filename = getenv ("GDBTK_FILENAME");
1309   if (!gdbtk_filename)
1310     if (access ("gdbtk.tcl", R_OK) == 0)
1311       gdbtk_filename = "gdbtk.tcl";
1312     else
1313       gdbtk_filename = GDBTK_FILENAME;
1314
1315 /* Defer setup of fputs_unfiltered_hook to near the end so that error messages
1316    prior to this point go to stdout/stderr.  */
1317
1318   fputs_unfiltered_hook = gdbtk_fputs;
1319
1320   if (Tcl_EvalFile (interp, gdbtk_filename) != TCL_OK)
1321     {
1322       fputs_unfiltered_hook = NULL; /* Force errors to stdout/stderr */
1323
1324       fprintf_unfiltered (stderr, "%s:%d: %s\n", gdbtk_filename,
1325                           interp->errorLine, interp->result);
1326
1327       fputs_unfiltered ("Stack trace:\n", gdb_stderr);
1328       fputs_unfiltered (Tcl_GetVar (interp, "errorInfo", 0), gdb_stderr);
1329       error ("");
1330     }
1331
1332   discard_cleanups (old_chain);
1333 }
1334
1335 /* Come here during initialize_all_files () */
1336
1337 void
1338 _initialize_gdbtk ()
1339 {
1340   if (use_windows)
1341     {
1342       /* Tell the rest of the world that Gdbtk is now set up. */
1343
1344       init_ui_hook = gdbtk_init;
1345     }
1346 }