gdb/gdbtk.c

   1 /* Tcl/Tk interface routines.
   2    Copyright 1994, 1995, 1996 Free Software Foundation, Inc.
   3
   4    Written by Stu Grossman <[email protected]> of Cygnus Support.
   5
   6 This file is part of GDB.
   7
   8 This program is free software; you can redistribute it and/or modify
   9 it under the terms of the GNU General Public License as published by
  10 the Free Software Foundation; either version 2 of the License, or
  11 (at your option) any later version.
  12
  13 This program is distributed in the hope that it will be useful,
  14 but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 GNU General Public License for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with this program; if not, write to the Free Software
  20 Foundation, Inc., 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 (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   if (argc != 3 && argc != 4)
 902     error ("wrong # args");
 903
 904   if (strcmp (argv[1], "source") == 0)
 905     mixed_source_and_assembly = 1;
 906   else if (strcmp (argv[1], "nosource") == 0)
 907     mixed_source_and_assembly = 0;
 908   else
 909     error ("First arg must be 'source' or 'nosource'");
 910
 911   low = parse_and_eval_address (argv[2]);
 912
 913   if (argc == 3)
 914     {
 915       if (find_pc_partial_function (low, NULL, &low, &high) == 0)
 916         error ("No function contains specified address");
 917     }
 918   else
 919     high = parse_and_eval_address (argv[3]);
 920
 921   /* If disassemble_from_exec == -1, then we use the following heuristic to
 922      determine whether or not to do disassembly from target memory or from the
 923      exec file:
 924
 925      If we're debugging a local process, read target memory, instead of the
 926      exec file.  This makes disassembly of functions in shared libs work
 927      correctly.
 928
 929      Else, we're debugging a remote process, and should disassemble from the
 930      exec file for speed.  However, this is no good if the target modifies its
 931      code (for relocation, or whatever).
 932    */
 933
 934   if (disassemble_from_exec == -1)
 935     if (strcmp (target_shortname, "child") == 0
 936         || strcmp (target_shortname, "procfs") == 0
 937         || strcmp (target_shortname, "vxprocess") == 0)
 938       disassemble_from_exec = 0; /* It's a child process, read inferior mem */
 939     else
 940       disassemble_from_exec = 1; /* It's remote, read the exec file */
 941
 942   if (disassemble_from_exec)
 943     di.read_memory_func = gdbtk_dis_asm_read_memory;
 944   else
 945     di.read_memory_func = dis_asm_read_memory;
 946
 947   /* If just doing straight assembly, all we need to do is disassemble
 948      everything between low and high.  If doing mixed source/assembly, we've
 949      got a totally different path to follow.  */
 950
 951   if (mixed_source_and_assembly)
 952     {                           /* Come here for mixed source/assembly */
 953       /* The idea here is to present a source-O-centric view of a function to
 954          the user.  This means that things are presented in source order, with
 955          (possibly) out of order assembly immediately following.  */
 956       struct symtab *symtab;
 957       struct linetable_entry *le;
 958       int nlines;
 959       int newlines;
 960       struct my_line_entry *mle;
 961       struct symtab_and_line sal;
 962       int i;
 963       int out_of_order;
 964       int next_line;
 965
 966       symtab = find_pc_symtab (low); /* Assume symtab is valid for whole PC range */
 967
 968       if (!symtab)
 969         goto assembly_only;
 970
 971 /* First, convert the linetable to a bunch of my_line_entry's.  */
 972
 973       le = symtab->linetable->item;
 974       nlines = symtab->linetable->nitems;
 975
 976       if (nlines <= 0)
 977         goto assembly_only;
 978
 979       mle = (struct my_line_entry *) alloca (nlines * sizeof (struct my_line_entry));
 980
 981       out_of_order = 0;
 982
 983 /* Copy linetable entries for this function into our data structure, creating
 984    end_pc's and setting out_of_order as appropriate.  */
 985
 986 /* First, skip all the preceding functions.  */
 987
 988       for (i = 0; i < nlines - 1 && le[i].pc < low; i++) ;
 989
 990 /* Now, copy all entries before the end of this function.  */
 991
 992       newlines = 0;
 993       for (; i < nlines - 1 && le[i].pc < high; i++)
 994         {
 995           if (le[i].line == le[i + 1].line
 996               && le[i].pc == le[i + 1].pc)
 997             continue;           /* Ignore duplicates */
 998
 999           mle[newlines].line = le[i].line;
1000           if (le[i].line > le[i + 1].line)
1001             out_of_order = 1;
1002           mle[newlines].start_pc = le[i].pc;
1003           mle[newlines].end_pc = le[i + 1].pc;
1004           newlines++;
1005         }
1006
1007 /* If we're on the last line, and it's part of the function, then we need to
1008    get the end pc in a special way.  */
1009
1010       if (i == nlines - 1
1011           && le[i].pc < high)
1012         {
1013           mle[newlines].line = le[i].line;
1014           mle[newlines].start_pc = le[i].pc;
1015           sal = find_pc_line (le[i].pc, 0);
1016           mle[newlines].end_pc = sal.end;
1017           newlines++;
1018         }
1019
1020 /* Now, sort mle by line #s (and, then by addresses within lines). */
1021
1022       if (out_of_order)
1023         qsort (mle, newlines, sizeof (struct my_line_entry), compare_lines);
1024
1025 /* Now, for each line entry, emit the specified lines (unless they have been
1026    emitted before), followed by the assembly code for that line.  */
1027
1028       next_line = 0;            /* Force out first line */
1029       for (i = 0; i < newlines; i++)
1030         {
1031 /* Print out everything from next_line to the current line.  */
1032
1033           if (mle[i].line >= next_line)
1034             {
1035               if (next_line != 0)
1036                 print_source_lines (symtab, next_line, mle[i].line + 1, 0);
1037               else
1038                 print_source_lines (symtab, mle[i].line, mle[i].line + 1, 0);
1039
1040               next_line = mle[i].line + 1;
1041             }
1042
1043           for (pc = mle[i].start_pc; pc < mle[i].end_pc; )
1044             {
1045               QUIT;
1046               fputs_unfiltered ("    ", gdb_stdout);
1047               print_address (pc, gdb_stdout);
1048               fputs_unfiltered (":\t    ", gdb_stdout);
1049               pc += (*tm_print_insn) (pc, &di);
1050               fputs_unfiltered ("\n", gdb_stdout);
1051             }
1052         }
1053     }
1054   else
1055     {
1056 assembly_only:
1057       for (pc = low; pc < high; )
1058         {
1059           QUIT;
1060           fputs_unfiltered ("    ", gdb_stdout);
1061           print_address (pc, gdb_stdout);
1062           fputs_unfiltered (":\t    ", gdb_stdout);
1063           pc += (*tm_print_insn) (pc, &di);
1064           fputs_unfiltered ("\n", gdb_stdout);
1065         }
1066     }
1067
1068   gdb_flush (gdb_stdout);
1069
1070   return TCL_OK;
1071 }
1072 \f
1073 static void
1074 tk_command (cmd, from_tty)
1075      char *cmd;
1076      int from_tty;
1077 {
1078   int retval;
1079   char *result;
1080   struct cleanup *old_chain;
1081
1082   /* Catch case of no argument, since this will make the tcl interpreter dump core. */
1083   if (cmd == NULL)
1084     error_no_arg ("tcl command to interpret");
1085
1086   retval = Tcl_Eval (interp, cmd);
1087
1088   result = strdup (interp->result);
1089
1090   old_chain = make_cleanup (free, result);
1091
1092   if (retval != TCL_OK)
1093     error (result);
1094
1095   printf_unfiltered ("%s\n", result);
1096
1097   do_cleanups (old_chain);
1098 }
1099
1100 static void
1101 cleanup_init (ignored)
1102      int ignored;
1103 {
1104   if (mainWindow != NULL)
1105     Tk_DestroyWindow (mainWindow);
1106   mainWindow = NULL;
1107
1108   if (interp != NULL)
1109     Tcl_DeleteInterp (interp);
1110   interp = NULL;
1111 }
1112
1113 /* Come here during long calculations to check for GUI events.  Usually invoked
1114    via the QUIT macro.  */
1115
1116 static void
1117 gdbtk_interactive ()
1118 {
1119   /* Tk_DoOneEvent (TK_DONT_WAIT|TK_IDLE_EVENTS); */
1120 }
1121
1122 /* Come here when there is activity on the X file descriptor. */
1123
1124 static void
1125 x_event (signo)
1126      int signo;
1127 {
1128   /* Process pending events */
1129
1130   while (Tk_DoOneEvent (TK_DONT_WAIT|TK_ALL_EVENTS) != 0);
1131 }
1132
1133 static int
1134 gdbtk_wait (pid, ourstatus)
1135      int pid;
1136      struct target_waitstatus *ourstatus;
1137 {
1138   struct sigaction action;
1139   static sigset_t nullsigmask = {0};
1140
1141 #ifndef SA_RESTART
1142   /* Needed for SunOS 4.1.x */
1143 #define SA_RESTART 0
1144 #endif
1145
1146   action.sa_handler = x_event;
1147   action.sa_mask = nullsigmask;
1148   action.sa_flags = SA_RESTART;
1149   sigaction(SIGIO, &action, NULL);
1150
1151   pid = target_wait (pid, ourstatus);
1152
1153   action.sa_handler = SIG_IGN;
1154   sigaction(SIGIO, &action, NULL);
1155
1156   return pid;
1157 }
1158
1159 /* This is called from execute_command, and provides a wrapper around
1160    various command routines in a place where both protocol messages and
1161    user input both flow through.  Mostly this is used for indicating whether
1162    the target process is running or not.
1163 */
1164
1165 static void
1166 gdbtk_call_command (cmdblk, arg, from_tty)
1167      struct cmd_list_element *cmdblk;
1168      char *arg;
1169      int from_tty;
1170 {
1171   running_now = 0;
1172   if (cmdblk->class == class_run)
1173     {
1174       running_now = 1;
1175       Tcl_Eval (interp, "gdbtk_tcl_busy");
1176       (*cmdblk->function.cfunc)(arg, from_tty);
1177       Tcl_Eval (interp, "gdbtk_tcl_idle");
1178       running_now = 0;
1179     }
1180   else
1181     (*cmdblk->function.cfunc)(arg, from_tty);
1182 }
1183
1184 /* This function is called instead of gdb's internal command loop.  This is the
1185    last chance to do anything before entering the main Tk event loop. */
1186
1187 static void
1188 tk_command_loop ()
1189 {
1190   extern GDB_FILE *instream;
1191
1192   /* We no longer want to use stdin as the command input stream */
1193   instream = NULL;
1194   Tcl_Eval (interp, "gdbtk_tcl_preloop");
1195   Tk_MainLoop ();
1196 }
1197
1198 static void
1199 gdbtk_init ()
1200 {
1201   struct cleanup *old_chain;
1202   char *gdbtk_filename;
1203   int i;
1204   struct sigaction action;
1205   static sigset_t nullsigmask = {0};
1206
1207   old_chain = make_cleanup (cleanup_init, 0);
1208
1209   /* First init tcl and tk. */
1210
1211   interp = Tcl_CreateInterp ();
1212
1213   if (!interp)
1214     error ("Tcl_CreateInterp failed");
1215
1216   mainWindow = Tk_CreateMainWindow (interp, NULL, "gdb", "Gdb");
1217
1218   if (!mainWindow)
1219     return;                     /* DISPLAY probably not set */
1220
1221   if (Tcl_Init(interp) != TCL_OK)
1222     error ("Tcl_Init failed: %s", interp->result);
1223
1224   if (Tk_Init(interp) != TCL_OK)
1225     error ("Tk_Init failed: %s", interp->result);
1226
1227   Tcl_CreateCommand (interp, "gdb_cmd", call_wrapper, gdb_cmd, NULL);
1228   Tcl_CreateCommand (interp, "gdb_loc", call_wrapper, gdb_loc, NULL);
1229   Tcl_CreateCommand (interp, "gdb_sourcelines", call_wrapper, gdb_sourcelines,
1230                      NULL);
1231   Tcl_CreateCommand (interp, "gdb_listfiles", call_wrapper, gdb_listfiles,
1232                      NULL);
1233   Tcl_CreateCommand (interp, "gdb_stop", call_wrapper, gdb_stop, NULL);
1234   Tcl_CreateCommand (interp, "gdb_regnames", call_wrapper, gdb_regnames, NULL);
1235   Tcl_CreateCommand (interp, "gdb_fetch_registers", call_wrapper,
1236                      gdb_fetch_registers, NULL);
1237   Tcl_CreateCommand (interp, "gdb_changed_register_list", call_wrapper,
1238                      gdb_changed_register_list, NULL);
1239   Tcl_CreateCommand (interp, "gdb_disassemble", call_wrapper,
1240                      gdb_disassemble, NULL);
1241   Tcl_CreateCommand (interp, "gdb_eval", call_wrapper, gdb_eval, NULL);
1242   Tcl_CreateCommand (interp, "gdb_get_breakpoint_list", call_wrapper,
1243                      gdb_get_breakpoint_list, NULL);
1244   Tcl_CreateCommand (interp, "gdb_get_breakpoint_info", call_wrapper,
1245                      gdb_get_breakpoint_info, NULL);
1246
1247   command_loop_hook = tk_command_loop;
1248   print_frame_info_listing_hook = null_routine;
1249   query_hook = gdbtk_query;
1250   flush_hook = gdbtk_flush;
1251   create_breakpoint_hook = gdbtk_create_breakpoint;
1252   delete_breakpoint_hook = gdbtk_delete_breakpoint;
1253   modify_breakpoint_hook = gdbtk_modify_breakpoint;
1254   interactive_hook = gdbtk_interactive;
1255   target_wait_hook = gdbtk_wait;
1256   call_command_hook = gdbtk_call_command;
1257   readline_begin_hook = gdbtk_readline_begin;
1258   readline_hook = gdbtk_readline;
1259   readline_end_hook = gdbtk_readline_end;
1260
1261   /* Get the file descriptor for the X server */
1262
1263   x_fd = ConnectionNumber (Tk_Display (mainWindow));
1264
1265   /* Setup for I/O interrupts */
1266
1267   action.sa_mask = nullsigmask;
1268   action.sa_flags = 0;
1269   action.sa_handler = SIG_IGN;
1270   sigaction(SIGIO, &action, NULL);
1271
1272 #ifdef FIOASYNC
1273   i = 1;
1274   if (ioctl (x_fd, FIOASYNC, &i))
1275     perror_with_name ("gdbtk_init: ioctl FIOASYNC failed");
1276
1277 #ifdef SIOCSPGRP
1278   i = getpid();
1279   if (ioctl (x_fd, SIOCSPGRP, &i))
1280     perror_with_name ("gdbtk_init: ioctl SIOCSPGRP failed");
1281
1282 #else
1283 #ifdef F_SETOWN
1284   i = getpid();
1285   if (fcntl (x_fd, F_SETOWN, i))
1286     perror_with_name ("gdbtk_init: fcntl F_SETOWN failed");
1287 #endif  /* F_SETOWN */
1288 #endif  /* !SIOCSPGRP */
1289 #else
1290   if (ioctl (x_fd,  I_SETSIG, S_INPUT|S_RDNORM) < 0)
1291     perror_with_name ("gdbtk_init: ioctl I_SETSIG failed");
1292 #endif /* ifndef FIOASYNC */
1293
1294   add_com ("tk", class_obscure, tk_command,
1295            "Send a command directly into tk.");
1296
1297   Tcl_LinkVar (interp, "disassemble-from-exec", (char *)&disassemble_from_exec,
1298                TCL_LINK_INT);
1299
1300   /* Load up gdbtk.tcl after all the environment stuff has been setup.  */
1301
1302   gdbtk_filename = getenv ("GDBTK_FILENAME");
1303   if (!gdbtk_filename)
1304     if (access ("gdbtk.tcl", R_OK) == 0)
1305       gdbtk_filename = "gdbtk.tcl";
1306     else
1307       gdbtk_filename = GDBTK_FILENAME;
1308
1309 /* Defer setup of fputs_unfiltered_hook to near the end so that error messages
1310    prior to this point go to stdout/stderr.  */
1311
1312   fputs_unfiltered_hook = gdbtk_fputs;
1313
1314   if (Tcl_EvalFile (interp, gdbtk_filename) != TCL_OK)
1315     {
1316       fputs_unfiltered_hook = NULL; /* Force errors to stdout/stderr */
1317
1318       fprintf_unfiltered (stderr, "%s:%d: %s\n", gdbtk_filename,
1319                           interp->errorLine, interp->result);
1320
1321       fputs_unfiltered ("Stack trace:\n", gdb_stderr);
1322       fputs_unfiltered (Tcl_GetVar (interp, "errorInfo", 0), gdb_stderr);
1323       error ("");
1324     }
1325
1326   discard_cleanups (old_chain);
1327 }
1328
1329 /* Come here during initialize_all_files () */
1330
1331 void
1332 _initialize_gdbtk ()
1333 {
1334   if (use_windows)
1335     {
1336       /* Tell the rest of the world that Gdbtk is now set up. */
1337
1338       init_ui_hook = gdbtk_init;
1339     }
1340 }