gdb/gdbtk.c

   1 /* Tcl/Tk interface routines.
   2    Copyright 1994, 1995, 1996, 1997 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 "gdbcore.h"
  31 #include "tracepoint.h"
  32
  33 #ifdef _WIN32
  34 #include <winuser.h>
  35 #endif
  36
  37 #include <tcl.h>
  38 #include <tk.h>
  39 #include <itcl.h>
  40 #include <tix.h>
  41 #include "guitcl.h"
  42
  43 #ifdef IDE
  44 /* start-sanitize-ide */
  45 #include "event.h"
  46 #include "idetcl.h"
  47 #include "ilutk.h"
  48 /* end-sanitize-ide */
  49 #endif
  50
  51 #ifdef ANSI_PROTOTYPES
  52 #include <stdarg.h>
  53 #else
  54 #include <varargs.h>
  55 #endif
  56 #include <signal.h>
  57 #include <fcntl.h>
  58 #include <unistd.h>
  59 #include <setjmp.h>
  60 #include "top.h"
  61 #include <sys/ioctl.h>
  62 #include "gdb_string.h"
  63 #include "dis-asm.h"
  64 #include <stdio.h>
  65 #include "gdbcmd.h"
  66
  67 #ifndef WINNT
  68 #ifndef FIOASYNC
  69 #include <sys/stropts.h>
  70 #endif
  71 #endif
  72
  73 #ifdef __CYGWIN32__
  74 #include <sys/time.h>
  75 #endif
  76
  77 #ifdef WINNT
  78 #define GDBTK_PATH_SEP ";"
  79 #else
  80 #define GDBTK_PATH_SEP ":"
  81 #endif
  82
  83 /* Some versions (1.3.79, 1.3.81) of Linux don't support SIOCSPGRP the way
  84    gdbtk wants to use it... */
  85 #ifdef __linux__
  86 #undef SIOCSPGRP
  87 #endif
  88
  89 int gdbtk_load_hash PARAMS ((char *, unsigned long));
  90 int (*ui_load_progress_hook) PARAMS ((char *, unsigned long));
  91
  92 static void null_routine PARAMS ((int));
  93 static void gdbtk_flush PARAMS ((FILE *));
  94 static void gdbtk_fputs PARAMS ((const char *, FILE *));
  95 static int gdbtk_query PARAMS ((const char *, va_list));
  96 static char *gdbtk_readline PARAMS ((char *));
  97 static void gdbtk_init PARAMS ((char *));
  98 static void tk_command_loop PARAMS ((void));
  99 static void gdbtk_call_command PARAMS ((struct cmd_list_element *, char *, int));
 100 static int gdbtk_wait PARAMS ((int, struct target_waitstatus *));
 101 static void x_event PARAMS ((int));
 102 static void gdbtk_interactive PARAMS ((void));
 103 static void cleanup_init PARAMS ((int));
 104 static void tk_command PARAMS ((char *, int));
 105 static int gdb_disassemble PARAMS ((ClientData, Tcl_Interp *, int, char *[]));
 106 static int compare_lines PARAMS ((const PTR, const PTR));
 107 static int gdbtk_dis_asm_read_memory PARAMS ((bfd_vma, bfd_byte *, int, disassemble_info *));
 108 static int gdb_path_conv PARAMS ((ClientData, Tcl_Interp *, int, char *[]));
 109 static int gdb_stop PARAMS ((ClientData, Tcl_Interp *, int, char *[]));
 110 static int gdb_confirm_quit PARAMS ((ClientData, Tcl_Interp *, int, char *[]));
 111 static int gdb_force_quit PARAMS ((ClientData, Tcl_Interp *, int, char *[]));
 112 static int gdb_listfiles PARAMS ((ClientData, Tcl_Interp *, int, char *[]));
 113 static int gdb_listfuncs PARAMS ((ClientData, Tcl_Interp *, int, char *[]));
 114 static int call_wrapper PARAMS ((ClientData, Tcl_Interp *, int, char *[]));
 115 static int gdb_cmd PARAMS ((ClientData, Tcl_Interp *, int, char *argv[]));
 116 static int gdb_fetch_registers PARAMS ((ClientData, Tcl_Interp *, int, char *[]));
 117 static void gdbtk_readline_end PARAMS ((void));
 118 static int gdb_changed_register_list PARAMS ((ClientData, Tcl_Interp *, int, char *[]));
 119 static void register_changed_p PARAMS ((int, void *));
 120 static int gdb_get_breakpoint_list PARAMS ((ClientData, Tcl_Interp *, int, char *[]));
 121 static int gdb_get_breakpoint_info PARAMS ((ClientData, Tcl_Interp *, int, char *[]));
 122 static void breakpoint_notify PARAMS ((struct breakpoint *, const char *));
 123 static void gdbtk_create_breakpoint PARAMS ((struct breakpoint *));
 124 static void gdbtk_delete_breakpoint PARAMS ((struct breakpoint *));
 125 static void gdbtk_modify_breakpoint PARAMS ((struct breakpoint *));
 126 static int gdb_loc PARAMS ((ClientData, Tcl_Interp *, int, char *[]));
 127 static int gdb_eval PARAMS ((ClientData, Tcl_Interp *, int, char *[]));
 128 static int gdb_sourcelines PARAMS ((ClientData, Tcl_Interp *, int, char *[]));
 129 static int map_arg_registers PARAMS ((int, char *[], void (*) (int, void *), void *));
 130 static void get_register_name PARAMS ((int, void *));
 131 static int gdb_regnames PARAMS ((ClientData, Tcl_Interp *, int, char *[]));
 132 static void get_register PARAMS ((int, void *));
 133 static int gdb_target_has_execution_command PARAMS ((ClientData, Tcl_Interp *, int, char *argv[]));
 134 static int gdb_load_info PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST objv[]));
 135 static int gdb_get_vars_command PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST objv[]));
 136 static int gdb_get_function_command PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST objv[]));
 137 static int gdb_get_line_command PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST objv[]));
 138 static int gdb_get_file_command PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST objv[]));
 139 static int gdb_tracepoint_exists_command PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST objv[]));
 140 static int gdb_get_tracepoint_info PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST objv[]));
 141 static int gdb_actions_command PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST objv[]));
 142 static int gdb_prompt_command PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST objv[]));
 143 static int gdb_find_file_command PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST objv[]));
 144 static int gdb_get_tracepoint_list PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST objv[]));
 145 static void gdbtk_create_tracepoint PARAMS ((struct tracepoint *));
 146 static void gdbtk_delete_tracepoint PARAMS ((struct tracepoint *));
 147 static void tracepoint_notify PARAMS ((struct tracepoint *, const char *));
 148
 149 /* Handle for TCL interpreter */
 150
 151 static Tcl_Interp *interp = NULL;
 152
 153 #ifndef WINNT
 154 static int x_fd;                /* X network socket */
 155 #endif
 156
 157 /* This variable is true when the inferior is running.  Although it's
 158    possible to disable most input from widgets and thus prevent
 159    attempts to do anything while the inferior is running, any commands
 160    that get through - even a simple memory read - are Very Bad, and
 161    may cause GDB to crash or behave strangely.  So, this variable
 162    provides an extra layer of defense.  */
 163
 164 static int running_now;
 165
 166 /* This variable determines where memory used for disassembly is read from.
 167    If > 0, then disassembly comes from the exec file rather than the
 168    target (which might be at the other end of a slow serial link).  If
 169    == 0 then disassembly comes from target.  If < 0 disassembly is
 170    automatically switched to the target if it's an inferior process,
 171    otherwise the exec file is used.  */
 172
 173 static int disassemble_from_exec = -1;
 174
 175 #ifndef _WIN32
 176
 177 /* Supply malloc calls for tcl/tk.  We do not want to do this on
 178    Windows, because Tcl_Alloc is probably in a DLL which will not call
 179    the mmalloc routines.  */
 180
 181 char *
 182 Tcl_Alloc (size)
 183      unsigned int size;
 184 {
 185   return xmalloc (size);
 186 }
 187
 188 char *
 189 Tcl_Realloc (ptr, size)
 190      char *ptr;
 191      unsigned int size;
 192 {
 193   return xrealloc (ptr, size);
 194 }
 195
 196 void
 197 Tcl_Free(ptr)
 198      char *ptr;
 199 {
 200   free (ptr);
 201 }
 202
 203 #endif /* ! _WIN32 */
 204
 205 static void
 206 null_routine(arg)
 207      int arg;
 208 {
 209 }
 210
 211 #ifdef _WIN32
 212
 213 /* On Windows, if we hold a file open, other programs can't write to
 214    it.  In particular, we don't want to hold the executable open,
 215    because it will mean that people have to get out of the debugging
 216    session in order to remake their program.  So we close it, although
 217    this will cost us if and when we need to reopen it.  */
 218
 219 static void
 220 close_bfds ()
 221 {
 222   struct objfile *o;
 223
 224   ALL_OBJFILES (o)
 225     {
 226       if (o->obfd != NULL)
 227         bfd_cache_close (o->obfd);
 228     }
 229
 230   if (exec_bfd != NULL)
 231     bfd_cache_close (exec_bfd);
 232 }
 233
 234 #endif /* _WIN32 */
 235
 236 /* The following routines deal with stdout/stderr data, which is created by
 237    {f}printf_{un}filtered and friends.  gdbtk_fputs and gdbtk_flush are the
 238    lowest level of these routines and capture all output from the rest of GDB.
 239    Normally they present their data to tcl via callbacks to the following tcl
 240    routines:  gdbtk_tcl_fputs, gdbtk_tcl_fputs_error, and gdbtk_flush.  These
 241    in turn call tk routines to update the display.
 242
 243    Under some circumstances, you may want to collect the output so that it can
 244    be returned as the value of a tcl procedure.  This can be done by
 245    surrounding the output routines with calls to start_saving_output and
 246    finish_saving_output.  The saved data can then be retrieved with
 247    get_saved_output (but this must be done before the call to
 248    finish_saving_output).  */
 249
 250 /* Dynamic string for output. */
 251
 252 static Tcl_DString *result_ptr;
 253
 254 /* Dynamic string for stderr.  This is only used if result_ptr is
 255    NULL.  */
 256
 257 static Tcl_DString *error_string_ptr;
 258 \f
 259 static void
 260 gdbtk_flush (stream)
 261      FILE *stream;
 262 {
 263 #if 0
 264   /* Force immediate screen update */
 265
 266   Tcl_VarEval (interp, "gdbtk_tcl_flush", NULL);
 267 #endif
 268 }
 269
 270 static void
 271 gdbtk_fputs (ptr, stream)
 272      const char *ptr;
 273      FILE *stream;
 274 {
 275   if (result_ptr)
 276     Tcl_DStringAppend (result_ptr, (char *) ptr, -1);
 277   else if (error_string_ptr != NULL && stream == gdb_stderr)
 278     Tcl_DStringAppend (error_string_ptr, (char *) ptr, -1);
 279   else
 280     {
 281       Tcl_DString str;
 282
 283       Tcl_DStringInit (&str);
 284
 285       Tcl_DStringAppend (&str, "gdbtk_tcl_fputs", -1);
 286       Tcl_DStringAppendElement (&str, (char *)ptr);
 287
 288       Tcl_Eval (interp, Tcl_DStringValue (&str));
 289       Tcl_DStringFree (&str);
 290     }
 291 }
 292
 293 static int
 294 gdbtk_query (query, args)
 295      const char *query;
 296      va_list args;
 297 {
 298   char buf[200], *merge[2];
 299   char *command;
 300   long val;
 301
 302   vsprintf (buf, query, args);
 303   merge[0] = "gdbtk_tcl_query";
 304   merge[1] = buf;
 305   command = Tcl_Merge (2, merge);
 306   Tcl_Eval (interp, command);
 307   Tcl_Free (command);
 308
 309   val = atol (interp->result);
 310   return val;
 311 }
 312
 313 /* VARARGS */
 314 static void
 315 #ifdef ANSI_PROTOTYPES
 316 gdbtk_readline_begin (char *format, ...)
 317 #else
 318 gdbtk_readline_begin (va_alist)
 319      va_dcl
 320 #endif
 321 {
 322   va_list args;
 323   char buf[200], *merge[2];
 324   char *command;
 325
 326 #ifdef ANSI_PROTOTYPES
 327   va_start (args, format);
 328 #else
 329   char *format;
 330   va_start (args);
 331   format = va_arg (args, char *);
 332 #endif
 333
 334   vsprintf (buf, format, args);
 335   merge[0] = "gdbtk_tcl_readline_begin";
 336   merge[1] = buf;
 337   command = Tcl_Merge (2, merge);
 338   Tcl_Eval (interp, command);
 339   free (command);
 340 }
 341
 342 static char *
 343 gdbtk_readline (prompt)
 344      char *prompt;
 345 {
 346   char *merge[2];
 347   char *command;
 348   int result;
 349
 350 #ifdef _WIN32
 351   close_bfds ();
 352 #endif
 353
 354   merge[0] = "gdbtk_tcl_readline";
 355   merge[1] = prompt;
 356   command = Tcl_Merge (2, merge);
 357   result = Tcl_Eval (interp, command);
 358   free (command);
 359   if (result == TCL_OK)
 360     {
 361       return (strdup (interp -> result));
 362     }
 363   else
 364     {
 365       gdbtk_fputs (interp -> result, gdb_stdout);
 366       gdbtk_fputs ("\n", gdb_stdout);
 367       return (NULL);
 368     }
 369 }
 370
 371 static void
 372 gdbtk_readline_end ()
 373 {
 374   Tcl_Eval (interp, "gdbtk_tcl_readline_end");
 375 }
 376
 377 \f
 378 static void
 379 #ifdef ANSI_PROTOTYPES
 380 dsprintf_append_element (Tcl_DString *dsp, char *format, ...)
 381 #else
 382 dsprintf_append_element (va_alist)
 383      va_dcl
 384 #endif
 385 {
 386   va_list args;
 387   char buf[1024];
 388
 389 #ifdef ANSI_PROTOTYPES
 390   va_start (args, format);
 391 #else
 392   Tcl_DString *dsp;
 393   char *format;
 394
 395   va_start (args);
 396   dsp = va_arg (args, Tcl_DString *);
 397   format = va_arg (args, char *);
 398 #endif
 399
 400   vsprintf (buf, format, args);
 401
 402   Tcl_DStringAppendElement (dsp, buf);
 403 }
 404
 405 static int
 406 gdb_path_conv (clientData, interp, argc, argv)
 407      ClientData clientData;
 408      Tcl_Interp *interp;
 409      int argc;
 410      char *argv[];
 411 {
 412 #ifdef WINNT
 413   char pathname[256], *ptr;
 414   if (argc != 2)
 415     error ("wrong # args");
 416   cygwin32_conv_to_full_win32_path (argv[1], pathname);
 417   for (ptr = pathname; *ptr; ptr++)
 418     {
 419       if (*ptr == '\\')
 420         *ptr = '/';
 421     }
 422 #else
 423   char *pathname = argv[1];
 424 #endif
 425   Tcl_DStringAppend (result_ptr, pathname, strlen(pathname));
 426   return TCL_OK;
 427 }
 428
 429 static int
 430 gdb_get_breakpoint_list (clientData, interp, argc, argv)
 431      ClientData clientData;
 432      Tcl_Interp *interp;
 433      int argc;
 434      char *argv[];
 435 {
 436   struct breakpoint *b;
 437   extern struct breakpoint *breakpoint_chain;
 438
 439   if (argc != 1)
 440     error ("wrong # args");
 441
 442   for (b = breakpoint_chain; b; b = b->next)
 443     if (b->type == bp_breakpoint)
 444       dsprintf_append_element (result_ptr, "%d", b->number);
 445
 446   return TCL_OK;
 447 }
 448
 449 static int
 450 gdb_get_breakpoint_info (clientData, interp, argc, argv)
 451      ClientData clientData;
 452      Tcl_Interp *interp;
 453      int argc;
 454      char *argv[];
 455 {
 456   struct symtab_and_line sal;
 457   static char *bptypes[] = {"breakpoint", "hardware breakpoint", "until",
 458                               "finish", "watchpoint", "hardware watchpoint",
 459                               "read watchpoint", "access watchpoint",
 460                               "longjmp", "longjmp resume", "step resume",
 461                               "through sigtramp", "watchpoint scope",
 462                               "call dummy" };
 463   static char *bpdisp[] = {"delete", "delstop", "disable", "donttouch"};
 464   struct command_line *cmd;
 465   int bpnum;
 466   struct breakpoint *b;
 467   extern struct breakpoint *breakpoint_chain;
 468   char *funcname, *filename;
 469
 470   if (argc != 2)
 471     error ("wrong # args");
 472
 473   bpnum = atoi (argv[1]);
 474
 475   for (b = breakpoint_chain; b; b = b->next)
 476     if (b->number == bpnum)
 477       break;
 478
 479   if (!b || b->type != bp_breakpoint)
 480     error ("Breakpoint #%d does not exist", bpnum);
 481
 482   sal = find_pc_line (b->address, 0);
 483
 484   filename = symtab_to_filename (sal.symtab);
 485   if (filename == NULL)
 486     filename = "N/A";
 487   Tcl_DStringAppendElement (result_ptr, filename);
 488   find_pc_partial_function (b->address, &funcname, NULL, NULL);
 489   Tcl_DStringAppendElement (result_ptr, funcname);
 490   dsprintf_append_element (result_ptr, "%d", sal.line);
 491   dsprintf_append_element (result_ptr, "0x%lx", b->address);
 492   Tcl_DStringAppendElement (result_ptr, bptypes[b->type]);
 493   Tcl_DStringAppendElement (result_ptr, b->enable == enabled ? "1" : "0");
 494   Tcl_DStringAppendElement (result_ptr, bpdisp[b->disposition]);
 495   dsprintf_append_element (result_ptr, "%d", b->ignore_count);
 496
 497   Tcl_DStringStartSublist (result_ptr);
 498   for (cmd = b->commands; cmd; cmd = cmd->next)
 499     Tcl_DStringAppendElement (result_ptr, cmd->line);
 500   Tcl_DStringEndSublist (result_ptr);
 501
 502   Tcl_DStringAppendElement (result_ptr, b->cond_string);
 503
 504   dsprintf_append_element (result_ptr, "%d", b->thread);
 505   dsprintf_append_element (result_ptr, "%d", b->hit_count);
 506
 507   return TCL_OK;
 508 }
 509
 510 static void
 511 breakpoint_notify(b, action)
 512      struct breakpoint *b;
 513      const char *action;
 514 {
 515   char buf[256];
 516   int v;
 517   struct symtab_and_line sal;
 518   char *filename;
 519
 520   if (b->type != bp_breakpoint)
 521     return;
 522
 523   /* We ensure that ACTION contains no special Tcl characters, so we
 524      can do this.  */
 525   sal = find_pc_line (b->address, 0);
 526   filename = symtab_to_filename (sal.symtab);
 527   if (filename == NULL)
 528     filename = "N/A";
 529   sprintf (buf, "gdbtk_tcl_breakpoint %s %d 0x%lx %d {%s}", action, b->number,
 530            (long)b->address, sal.line, filename);
 531
 532   v = Tcl_Eval (interp, buf);
 533
 534   if (v != TCL_OK)
 535     {
 536       gdbtk_fputs (interp->result, gdb_stdout);
 537       gdbtk_fputs ("\n", gdb_stdout);
 538     }
 539 }
 540
 541 static void
 542 gdbtk_create_breakpoint(b)
 543      struct breakpoint *b;
 544 {
 545   breakpoint_notify (b, "create");
 546 }
 547
 548 static void
 549 gdbtk_delete_breakpoint(b)
 550      struct breakpoint *b;
 551 {
 552   breakpoint_notify (b, "delete");
 553 }
 554
 555 static void
 556 gdbtk_modify_breakpoint(b)
 557      struct breakpoint *b;
 558 {
 559   breakpoint_notify (b, "modify");
 560 }
 561 \f
 562 /* This implements the TCL command `gdb_loc', which returns a list consisting
 563    of the source and line number associated with the current pc. */
 564
 565 static int
 566 gdb_loc (clientData, interp, argc, argv)
 567      ClientData clientData;
 568      Tcl_Interp *interp;
 569      int argc;
 570      char *argv[];
 571 {
 572   char *filename;
 573   struct symtab_and_line sal;
 574   char *funcname;
 575   CORE_ADDR pc;
 576
 577   if (!have_full_symbols () && !have_partial_symbols ())
 578     {
 579       Tcl_SetResult (interp, "No symbol table is loaded", TCL_STATIC);
 580       return TCL_ERROR;
 581     }
 582
 583   if (argc == 1)
 584     {
 585       pc = selected_frame ? selected_frame->pc : stop_pc;
 586       sal = find_pc_line (pc, 0);
 587     }
 588   else if (argc == 2)
 589     {
 590       struct symtabs_and_lines sals;
 591       int nelts;
 592
 593       sals = decode_line_spec (argv[1], 1);
 594
 595       nelts = sals.nelts;
 596       sal = sals.sals[0];
 597       free (sals.sals);
 598
 599       if (sals.nelts != 1)
 600         error ("Ambiguous line spec");
 601
 602       pc = sal.pc;
 603     }
 604   else
 605     error ("wrong # args");
 606
 607   if (sal.symtab)
 608     Tcl_DStringAppendElement (result_ptr, sal.symtab->filename);
 609   else
 610     Tcl_DStringAppendElement (result_ptr, "");
 611
 612   find_pc_partial_function (pc, &funcname, NULL, NULL);
 613   Tcl_DStringAppendElement (result_ptr, funcname);
 614
 615   filename = symtab_to_filename (sal.symtab);
 616   if (filename == NULL)
 617     filename = "N/A";
 618   Tcl_DStringAppendElement (result_ptr, filename);
 619
 620   dsprintf_append_element (result_ptr, "%d", sal.line); /* line number */
 621
 622   dsprintf_append_element (result_ptr, "0x%s", paddr_nz(pc)); /* PC in current frame */
 623
 624   dsprintf_append_element (result_ptr, "0x%s", paddr_nz(stop_pc)); /* Real PC */
 625
 626   return TCL_OK;
 627 }
 628 \f
 629 /* This implements the TCL command `gdb_eval'. */
 630
 631 static int
 632 gdb_eval (clientData, interp, argc, argv)
 633      ClientData clientData;
 634      Tcl_Interp *interp;
 635      int argc;
 636      char *argv[];
 637 {
 638   struct expression *expr;
 639   struct cleanup *old_chain;
 640   value_ptr val;
 641
 642   if (argc != 2)
 643     error ("wrong # args");
 644
 645   expr = parse_expression (argv[1]);
 646
 647   old_chain = make_cleanup (free_current_contents, &expr);
 648
 649   val = evaluate_expression (expr);
 650
 651   val_print (VALUE_TYPE (val), VALUE_CONTENTS (val), VALUE_ADDRESS (val),
 652              gdb_stdout, 0, 0, 0, 0);
 653
 654   do_cleanups (old_chain);
 655
 656   return TCL_OK;
 657 }
 658
 659 /* gdb_get_mem addr form size num aschar*/
 660 /* dump a block of memory */
 661 /* addr: address of data to dump */
 662 /* form: a char indicating format */
 663 /* size: size of each element; 1,2,4, or 8 bytes*/
 664 /* num: the number of 'size' elements to return */
 665 /* acshar:  an optional ascii character to use in ASCII dump */
 666 /* returns a list of 'num' elements followed by an optional */
 667 /* ASCII dump */
 668 static int
 669 gdb_get_mem (clientData, interp, argc, argv)
 670      ClientData clientData;
 671      Tcl_Interp *interp;
 672      int argc;
 673      char *argv[];
 674 {
 675   int size, asize, num, i, j;
 676   CORE_ADDR addr, saved_addr, ptr;
 677   int format;
 678   struct type *val_type;
 679   value_ptr vptr;
 680   char c, buff[128], aschar;
 681
 682   if (argc != 6)
 683     error ("wrong # args");
 684
 685   addr = (CORE_ADDR)strtoul(argv[1],(char **)NULL,0);
 686   saved_addr = addr;
 687   format = *argv[2];
 688   size = (int)strtoul(argv[3],(char **)NULL,0);
 689   num = (int)strtoul(argv[4],(char **)NULL,0);
 690   aschar = *argv[5];
 691
 692   switch (size) {
 693   case 1:
 694     val_type = builtin_type_char;
 695     asize = 'b';
 696     break;
 697   case 2:
 698     val_type = builtin_type_short;
 699     asize = 'h';
 700     break;
 701   case 4:
 702     val_type = builtin_type_int;
 703     asize = 'w';
 704     break;
 705   case 8:
 706     val_type = builtin_type_long_long;
 707     asize = 'g';
 708     break;
 709   default:
 710     val_type = builtin_type_char;
 711     asize = 'b';
 712   }
 713
 714   for (i=0; i < num; i++)
 715     {
 716       vptr = value_at (val_type, addr, (asection *)NULL);
 717       print_scalar_formatted (VALUE_CONTENTS(vptr), val_type, format, asize, gdb_stdout);
 718       fputs_unfiltered (" ", gdb_stdout);
 719       addr += size;
 720     }
 721
 722   if (aschar)
 723     {
 724       val_type = builtin_type_char;
 725       ptr = saved_addr;
 726       buff[0] = '"';
 727       i = 1;
 728       for (j=0; j < num*size; j++)
 729         {
 730           c = *(char *)VALUE_CONTENTS(value_at (val_type, ptr, (asection *)NULL));
 731           if (c < 32 || c > 126)
 732             c = aschar;
 733           if (c == '"')
 734             buff[i++] = '\\';
 735           buff[i++] = c;
 736           ptr++;
 737         }
 738       buff[i++] = '"';
 739       buff[i] = 0;
 740       fputs_unfiltered (buff, gdb_stdout);
 741     }
 742
 743   return TCL_OK;
 744 }
 745
 746
 747 /* This implements the TCL command `gdb_sourcelines', which returns a list of
 748    all of the lines containing executable code for the specified source file
 749    (ie: lines where you can put breakpoints). */
 750
 751 static int
 752 gdb_sourcelines (clientData, interp, argc, argv)
 753      ClientData clientData;
 754      Tcl_Interp *interp;
 755      int argc;
 756      char *argv[];
 757 {
 758   struct symtab *symtab;
 759   struct linetable_entry *le;
 760   int nlines;
 761
 762   if (argc != 2)
 763     error ("wrong # args");
 764
 765   symtab = lookup_symtab (argv[1]);
 766
 767   if (!symtab)
 768     error ("No such file");
 769
 770   /* If there's no linetable, or no entries, then we are done. */
 771
 772   if (!symtab->linetable
 773       || symtab->linetable->nitems == 0)
 774     {
 775       Tcl_DStringAppendElement (result_ptr, "");
 776       return TCL_OK;
 777     }
 778
 779   le = symtab->linetable->item;
 780   nlines = symtab->linetable->nitems;
 781
 782   for (;nlines > 0; nlines--, le++)
 783     {
 784       /* If the pc of this line is the same as the pc of the next line, then
 785          just skip it.  */
 786       if (nlines > 1
 787           && le->pc == (le + 1)->pc)
 788         continue;
 789
 790       dsprintf_append_element (result_ptr, "%d", le->line);
 791     }
 792
 793   return TCL_OK;
 794 }
 795 \f
 796 static int
 797 map_arg_registers (argc, argv, func, argp)
 798      int argc;
 799      char *argv[];
 800      void (*func) PARAMS ((int regnum, void *argp));
 801      void *argp;
 802 {
 803   int regnum;
 804
 805   /* Note that the test for a valid register must include checking the
 806      reg_names array because NUM_REGS may be allocated for the union of the
 807      register sets within a family of related processors.  In this case, the
 808      trailing entries of reg_names will change depending upon the particular
 809      processor being debugged.  */
 810
 811   if (argc == 0)                /* No args, just do all the regs */
 812     {
 813       for (regnum = 0;
 814            regnum < NUM_REGS
 815            && reg_names[regnum] != NULL
 816            && *reg_names[regnum] != '\000';
 817            regnum++)
 818         func (regnum, argp);
 819
 820       return TCL_OK;
 821     }
 822
 823   /* Else, list of register #s, just do listed regs */
 824   for (; argc > 0; argc--, argv++)
 825     {
 826       regnum = atoi (*argv);
 827
 828       if (regnum >= 0
 829           && regnum < NUM_REGS
 830           && reg_names[regnum] != NULL
 831           && *reg_names[regnum] != '\000')
 832         func (regnum, argp);
 833       else
 834         error ("bad register number");
 835     }
 836
 837   return TCL_OK;
 838 }
 839
 840 static void
 841 get_register_name (regnum, argp)
 842      int regnum;
 843      void *argp;                /* Ignored */
 844 {
 845   Tcl_DStringAppendElement (result_ptr, reg_names[regnum]);
 846 }
 847
 848 /* This implements the TCL command `gdb_regnames', which returns a list of
 849    all of the register names. */
 850
 851 static int
 852 gdb_regnames (clientData, interp, argc, argv)
 853      ClientData clientData;
 854      Tcl_Interp *interp;
 855      int argc;
 856      char *argv[];
 857 {
 858   argc--;
 859   argv++;
 860
 861   return map_arg_registers (argc, argv, get_register_name, NULL);
 862 }
 863
 864 #ifndef REGISTER_CONVERTIBLE
 865 #define REGISTER_CONVERTIBLE(x) (0 != 0)
 866 #endif
 867
 868 #ifndef REGISTER_CONVERT_TO_VIRTUAL
 869 #define REGISTER_CONVERT_TO_VIRTUAL(x, y, z, a)
 870 #endif
 871
 872 #ifndef INVALID_FLOAT
 873 #define INVALID_FLOAT(x, y) (0 != 0)
 874 #endif
 875
 876 static void
 877 get_register (regnum, fp)
 878      int regnum;
 879      void *fp;
 880 {
 881   char raw_buffer[MAX_REGISTER_RAW_SIZE];
 882   char virtual_buffer[MAX_REGISTER_VIRTUAL_SIZE];
 883   int format = (int)fp;
 884
 885   if (read_relative_register_raw_bytes (regnum, raw_buffer))
 886     {
 887       Tcl_DStringAppendElement (result_ptr, "Optimized out");
 888       return;
 889     }
 890
 891   /* Convert raw data to virtual format if necessary.  */
 892
 893   if (REGISTER_CONVERTIBLE (regnum))
 894     {
 895       REGISTER_CONVERT_TO_VIRTUAL (regnum, REGISTER_VIRTUAL_TYPE (regnum),
 896                                    raw_buffer, virtual_buffer);
 897     }
 898   else
 899     memcpy (virtual_buffer, raw_buffer, REGISTER_VIRTUAL_SIZE (regnum));
 900
 901   if (format == 'r')
 902     {
 903       int j;
 904       printf_filtered ("0x");
 905       for (j = 0; j < REGISTER_RAW_SIZE (regnum); j++)
 906         {
 907           register int idx = TARGET_BYTE_ORDER == BIG_ENDIAN ? j
 908             : REGISTER_RAW_SIZE (regnum) - 1 - j;
 909           printf_filtered ("%02x", (unsigned char)raw_buffer[idx]);
 910         }
 911     }
 912   else
 913     val_print (REGISTER_VIRTUAL_TYPE (regnum), virtual_buffer, 0,
 914                gdb_stdout, format, 1, 0, Val_pretty_default);
 915
 916   Tcl_DStringAppend (result_ptr, " ", -1);
 917 }
 918
 919 static int
 920 gdb_fetch_registers (clientData, interp, argc, argv)
 921      ClientData clientData;
 922      Tcl_Interp *interp;
 923      int argc;
 924      char *argv[];
 925 {
 926   int format;
 927
 928   if (argc < 2)
 929     error ("wrong # args");
 930
 931   argc--;
 932   argv++;
 933
 934   argc--;
 935   format = **argv++;
 936
 937   return map_arg_registers (argc, argv, get_register, (void *) format);
 938 }
 939
 940 /* This contains the previous values of the registers, since the last call to
 941    gdb_changed_register_list.  */
 942
 943 static char old_regs[REGISTER_BYTES];
 944
 945 static void
 946 register_changed_p (regnum, argp)
 947      int regnum;
 948      void *argp;                /* Ignored */
 949 {
 950   char raw_buffer[MAX_REGISTER_RAW_SIZE];
 951
 952   if (read_relative_register_raw_bytes (regnum, raw_buffer))
 953     return;
 954
 955   if (memcmp (&old_regs[REGISTER_BYTE (regnum)], raw_buffer,
 956               REGISTER_RAW_SIZE (regnum)) == 0)
 957     return;
 958
 959   /* Found a changed register.  Save new value and return its number. */
 960
 961   memcpy (&old_regs[REGISTER_BYTE (regnum)], raw_buffer,
 962           REGISTER_RAW_SIZE (regnum));
 963
 964   dsprintf_append_element (result_ptr, "%d", regnum);
 965 }
 966
 967 static int
 968 gdb_changed_register_list (clientData, interp, argc, argv)
 969      ClientData clientData;
 970      Tcl_Interp *interp;
 971      int argc;
 972      char *argv[];
 973 {
 974   argc--;
 975   argv++;
 976
 977   return map_arg_registers (argc, argv, register_changed_p, NULL);
 978 }
 979 \f
 980 /* This implements the TCL command `gdb_cmd', which sends its argument into
 981    the GDB command scanner.  */
 982
 983 static int
 984 gdb_cmd (clientData, interp, argc, argv)
 985      ClientData clientData;
 986      Tcl_Interp *interp;
 987      int argc;
 988      char *argv[];
 989 {
 990   Tcl_DString *save_ptr = NULL;
 991
 992   if (argc != 2)
 993     error ("wrong # args");
 994
 995   if (running_now)
 996     return TCL_OK;
 997
 998   /* for the load instruction (and possibly others later) we
 999      set result_ptr to NULL so gdbtk_fputs() will not buffer
1000      all the data until the command is finished. */
1001
1002   if (strncmp ("load ", argv[1], 5) == 0
1003       || strncmp ("while ", argv[1], 6) == 0)
1004     {
1005       Tcl_DStringAppend (result_ptr, "", -1);
1006       save_ptr = result_ptr;
1007       result_ptr = NULL;
1008     }
1009
1010   execute_command (argv[1], 1);
1011
1012   bpstat_do_actions (&stop_bpstat);
1013
1014   if (save_ptr)
1015     result_ptr = save_ptr;
1016
1017   return TCL_OK;
1018 }
1019
1020 /* Client of call_wrapper - this routine performs the actual call to
1021    the client function. */
1022
1023 struct wrapped_call_args
1024 {
1025   Tcl_Interp *interp;
1026   Tcl_CmdProc *func;
1027   int argc;
1028   char **argv;
1029   int val;
1030 };
1031
1032 static int
1033 wrapped_call (args)
1034      struct wrapped_call_args *args;
1035 {
1036   args->val = (*args->func) (args->func, args->interp, args->argc, args->argv);
1037   return 1;
1038 }
1039
1040 /* This routine acts as a top-level for all GDB code called by tcl/Tk.  It
1041    handles cleanups, and calls to return_to_top_level (usually via error).
1042    This is necessary in order to prevent a longjmp out of the bowels of Tk,
1043    possibly leaving things in a bad state.  Since this routine can be called
1044    recursively, it needs to save and restore the contents of the jmp_buf as
1045    necessary.  */
1046
1047 static int
1048 call_wrapper (clientData, interp, argc, argv)
1049      ClientData clientData;
1050      Tcl_Interp *interp;
1051      int argc;
1052      char *argv[];
1053 {
1054   struct wrapped_call_args wrapped_args;
1055   Tcl_DString result, *old_result_ptr;
1056   Tcl_DString error_string, *old_error_string_ptr;
1057
1058   Tcl_DStringInit (&result);
1059   old_result_ptr = result_ptr;
1060   result_ptr = &result;
1061
1062   Tcl_DStringInit (&error_string);
1063   old_error_string_ptr = error_string_ptr;
1064   error_string_ptr = &error_string;
1065
1066   wrapped_args.func = (Tcl_CmdProc *)clientData;
1067   wrapped_args.interp = interp;
1068   wrapped_args.argc = argc;
1069   wrapped_args.argv = argv;
1070   wrapped_args.val = 0;
1071
1072   if (!catch_errors (wrapped_call, &wrapped_args, "", RETURN_MASK_ALL))
1073     {
1074       wrapped_args.val = TCL_ERROR;     /* Flag an error for TCL */
1075
1076       gdb_flush (gdb_stderr);   /* Flush error output */
1077
1078       gdb_flush (gdb_stdout);   /* Sometimes error output comes here as well */
1079
1080       /* In case of an error, we may need to force the GUI into idle
1081          mode because gdbtk_call_command may have bombed out while in
1082          the command routine.  */
1083
1084       running_now = 0;
1085       Tcl_Eval (interp, "gdbtk_tcl_idle");
1086     }
1087
1088   if (Tcl_DStringLength (&error_string) == 0)
1089     {
1090       Tcl_DStringResult (interp, &result);
1091       Tcl_DStringFree (&error_string);
1092     }
1093   else if (Tcl_DStringLength (&result) == 0)
1094     {
1095       Tcl_DStringResult (interp, &error_string);
1096       Tcl_DStringFree (&result);
1097     }
1098   else
1099     {
1100       Tcl_ResetResult (interp);
1101       Tcl_AppendResult (interp, Tcl_DStringValue (&result),
1102                         Tcl_DStringValue (&error_string), (char *) NULL);
1103       Tcl_DStringFree (&result);
1104       Tcl_DStringFree (&error_string);
1105     }
1106
1107   result_ptr = old_result_ptr;
1108   error_string_ptr = old_error_string_ptr;
1109
1110 #ifdef _WIN32
1111   close_bfds ();
1112 #endif
1113
1114   return wrapped_args.val;
1115 }
1116
1117 static int
1118 gdb_listfiles (clientData, interp, argc, argv)
1119      ClientData clientData;
1120      Tcl_Interp *interp;
1121      int argc;
1122      char *argv[];
1123 {
1124   struct objfile *objfile;
1125   struct partial_symtab *psymtab;
1126   struct symtab *symtab;
1127
1128   ALL_PSYMTABS (objfile, psymtab)
1129     Tcl_DStringAppendElement (result_ptr, psymtab->filename);
1130
1131   ALL_SYMTABS (objfile, symtab)
1132     Tcl_DStringAppendElement (result_ptr, symtab->filename);
1133
1134   return TCL_OK;
1135 }
1136
1137 static int
1138 gdb_listfuncs (clientData, interp, argc, argv)
1139      ClientData clientData;
1140      Tcl_Interp *interp;
1141      int argc;
1142      char *argv[];
1143 {
1144   struct symtab *symtab;
1145   struct blockvector *bv;
1146   struct block *b;
1147   struct symbol *sym;
1148   int i,j;
1149
1150   if (argc != 2)
1151     error ("wrong # args");
1152
1153   symtab = lookup_symtab (argv[1]);
1154
1155   if (!symtab)
1156     error ("No such file");
1157
1158   bv = BLOCKVECTOR (symtab);
1159   for (i = GLOBAL_BLOCK; i <= STATIC_BLOCK; i++)
1160     {
1161       b = BLOCKVECTOR_BLOCK (bv, i);
1162       /* Skip the sort if this block is always sorted.  */
1163       if (!BLOCK_SHOULD_SORT (b))
1164         sort_block_syms (b);
1165       for (j = 0; j < BLOCK_NSYMS (b); j++)
1166         {
1167           sym = BLOCK_SYM (b, j);
1168           if (SYMBOL_CLASS (sym) == LOC_BLOCK)
1169             {
1170               Tcl_DStringAppendElement (result_ptr, SYMBOL_NAME(sym));
1171             }
1172         }
1173     }
1174   return TCL_OK;
1175 }
1176
1177 static int
1178 gdb_stop (clientData, interp, argc, argv)
1179      ClientData clientData;
1180      Tcl_Interp *interp;
1181      int argc;
1182      char *argv[];
1183 {
1184   if (target_stop)
1185     target_stop ();
1186   else
1187     quit_flag = 1; /* hope something sees this */
1188
1189   return TCL_OK;
1190 }
1191
1192 /* Prepare to accept a new executable file.  This is called when we
1193    want to clear away everything we know about the old file, without
1194    asking the user.  The Tcl code will have already asked the user if
1195    necessary.  After this is called, we should be able to run the
1196    `file' command without getting any questions.  */
1197
1198 static int
1199 gdb_clear_file (clientData, interp, argc, argv)
1200      ClientData clientData;
1201      Tcl_Interp *interp;
1202      int argc;
1203      char *argv[];
1204 {
1205   if (inferior_pid != 0 && target_has_execution)
1206     {
1207       if (attach_flag)
1208         target_detach (NULL, 0);
1209       else
1210         target_kill ();
1211     }
1212
1213   if (target_has_execution)
1214     pop_target ();
1215
1216   symbol_file_command (NULL, 0);
1217
1218   return TCL_OK;
1219 }
1220
1221 /* Ask the user to confirm an exit request.  */
1222
1223 static int
1224 gdb_confirm_quit (clientData, interp, argc, argv)
1225      ClientData clientData;
1226      Tcl_Interp *interp;
1227      int argc;
1228      char *argv[];
1229 {
1230   int ret;
1231
1232   ret = quit_confirm ();
1233   Tcl_DStringAppendElement (result_ptr, ret ? "1" : "0");
1234   return TCL_OK;
1235 }
1236
1237 /* Quit without asking for confirmation.  */
1238
1239 static int
1240 gdb_force_quit (clientData, interp, argc, argv)
1241      ClientData clientData;
1242      Tcl_Interp *interp;
1243      int argc;
1244      char *argv[];
1245 {
1246   quit_force ((char *) NULL, 1);
1247   return TCL_OK;
1248 }
1249 \f
1250 /* This implements the TCL command `gdb_disassemble'.  */
1251
1252 static int
1253 gdbtk_dis_asm_read_memory (memaddr, myaddr, len, info)
1254      bfd_vma memaddr;
1255      bfd_byte *myaddr;
1256      int len;
1257      disassemble_info *info;
1258 {
1259   extern struct target_ops exec_ops;
1260   int res;
1261
1262   errno = 0;
1263   res = xfer_memory (memaddr, myaddr, len, 0, &exec_ops);
1264
1265   if (res == len)
1266     return 0;
1267   else
1268     if (errno == 0)
1269       return EIO;
1270     else
1271       return errno;
1272 }
1273
1274 /* We need a different sort of line table from the normal one cuz we can't
1275    depend upon implicit line-end pc's for lines.  This is because of the
1276    reordering we are about to do.  */
1277
1278 struct my_line_entry {
1279   int line;
1280   CORE_ADDR start_pc;
1281   CORE_ADDR end_pc;
1282 };
1283
1284 static int
1285 compare_lines (mle1p, mle2p)
1286      const PTR mle1p;
1287      const PTR mle2p;
1288 {
1289   struct my_line_entry *mle1, *mle2;
1290   int val;
1291
1292   mle1 = (struct my_line_entry *) mle1p;
1293   mle2 = (struct my_line_entry *) mle2p;
1294
1295   val =  mle1->line - mle2->line;
1296
1297   if (val != 0)
1298     return val;
1299
1300   return mle1->start_pc - mle2->start_pc;
1301 }
1302
1303 static int
1304 gdb_disassemble (clientData, interp, argc, argv)
1305      ClientData clientData;
1306      Tcl_Interp *interp;
1307      int argc;
1308      char *argv[];
1309 {
1310   CORE_ADDR pc, low, high;
1311   int mixed_source_and_assembly;
1312   static disassemble_info di;
1313   static int di_initialized;
1314
1315   if (! di_initialized)
1316     {
1317       INIT_DISASSEMBLE_INFO_NO_ARCH (di, gdb_stdout,
1318                                      (fprintf_ftype) fprintf_unfiltered);
1319       di.flavour = bfd_target_unknown_flavour;
1320       di.memory_error_func = dis_asm_memory_error;
1321       di.print_address_func = dis_asm_print_address;
1322       di_initialized = 1;
1323     }
1324
1325   di.mach = tm_print_insn_info.mach;
1326   if (TARGET_BYTE_ORDER == BIG_ENDIAN)
1327     di.endian = BFD_ENDIAN_BIG;
1328   else
1329     di.endian = BFD_ENDIAN_LITTLE;
1330
1331   if (argc != 3 && argc != 4)
1332     error ("wrong # args");
1333
1334   if (strcmp (argv[1], "source") == 0)
1335     mixed_source_and_assembly = 1;
1336   else if (strcmp (argv[1], "nosource") == 0)
1337     mixed_source_and_assembly = 0;
1338   else
1339     error ("First arg must be 'source' or 'nosource'");
1340
1341   low = parse_and_eval_address (argv[2]);
1342
1343   if (argc == 3)
1344     {
1345       if (find_pc_partial_function (low, NULL, &low, &high) == 0)
1346         error ("No function contains specified address");
1347     }
1348   else
1349     high = parse_and_eval_address (argv[3]);
1350
1351   /* If disassemble_from_exec == -1, then we use the following heuristic to
1352      determine whether or not to do disassembly from target memory or from the
1353      exec file:
1354
1355      If we're debugging a local process, read target memory, instead of the
1356      exec file.  This makes disassembly of functions in shared libs work
1357      correctly.
1358
1359      Else, we're debugging a remote process, and should disassemble from the
1360      exec file for speed.  However, this is no good if the target modifies its
1361      code (for relocation, or whatever).
1362    */
1363
1364   if (disassemble_from_exec == -1)
1365     if (strcmp (target_shortname, "child") == 0
1366         || strcmp (target_shortname, "procfs") == 0
1367         || strcmp (target_shortname, "vxprocess") == 0)
1368       disassemble_from_exec = 0; /* It's a child process, read inferior mem */
1369     else
1370       disassemble_from_exec = 1; /* It's remote, read the exec file */
1371
1372   if (disassemble_from_exec)
1373     di.read_memory_func = gdbtk_dis_asm_read_memory;
1374   else
1375     di.read_memory_func = dis_asm_read_memory;
1376
1377   /* If just doing straight assembly, all we need to do is disassemble
1378      everything between low and high.  If doing mixed source/assembly, we've
1379      got a totally different path to follow.  */
1380
1381   if (mixed_source_and_assembly)
1382     {                           /* Come here for mixed source/assembly */
1383       /* The idea here is to present a source-O-centric view of a function to
1384          the user.  This means that things are presented in source order, with
1385          (possibly) out of order assembly immediately following.  */
1386       struct symtab *symtab;
1387       struct linetable_entry *le;
1388       int nlines;
1389       int newlines;
1390       struct my_line_entry *mle;
1391       struct symtab_and_line sal;
1392       int i;
1393       int out_of_order;
1394       int next_line;
1395
1396       symtab = find_pc_symtab (low); /* Assume symtab is valid for whole PC range */
1397
1398       if (!symtab)
1399         goto assembly_only;
1400
1401 /* First, convert the linetable to a bunch of my_line_entry's.  */
1402
1403       le = symtab->linetable->item;
1404       nlines = symtab->linetable->nitems;
1405
1406       if (nlines <= 0)
1407         goto assembly_only;
1408
1409       mle = (struct my_line_entry *) alloca (nlines * sizeof (struct my_line_entry));
1410
1411       out_of_order = 0;
1412
1413 /* Copy linetable entries for this function into our data structure, creating
1414    end_pc's and setting out_of_order as appropriate.  */
1415
1416 /* First, skip all the preceding functions.  */
1417
1418       for (i = 0; i < nlines - 1 && le[i].pc < low; i++) ;
1419
1420 /* Now, copy all entries before the end of this function.  */
1421
1422       newlines = 0;
1423       for (; i < nlines - 1 && le[i].pc < high; i++)
1424         {
1425           if (le[i].line == le[i + 1].line
1426               && le[i].pc == le[i + 1].pc)
1427             continue;           /* Ignore duplicates */
1428
1429           mle[newlines].line = le[i].line;
1430           if (le[i].line > le[i + 1].line)
1431             out_of_order = 1;
1432           mle[newlines].start_pc = le[i].pc;
1433           mle[newlines].end_pc = le[i + 1].pc;
1434           newlines++;
1435         }
1436
1437 /* If we're on the last line, and it's part of the function, then we need to
1438    get the end pc in a special way.  */
1439
1440       if (i == nlines - 1
1441           && le[i].pc < high)
1442         {
1443           mle[newlines].line = le[i].line;
1444           mle[newlines].start_pc = le[i].pc;
1445           sal = find_pc_line (le[i].pc, 0);
1446           mle[newlines].end_pc = sal.end;
1447           newlines++;
1448         }
1449
1450 /* Now, sort mle by line #s (and, then by addresses within lines). */
1451
1452       if (out_of_order)
1453         qsort (mle, newlines, sizeof (struct my_line_entry), compare_lines);
1454
1455 /* Now, for each line entry, emit the specified lines (unless they have been
1456    emitted before), followed by the assembly code for that line.  */
1457
1458       next_line = 0;            /* Force out first line */
1459       for (i = 0; i < newlines; i++)
1460         {
1461 /* Print out everything from next_line to the current line.  */
1462
1463           if (mle[i].line >= next_line)
1464             {
1465               if (next_line != 0)
1466                 print_source_lines (symtab, next_line, mle[i].line + 1, 0);
1467               else
1468                 print_source_lines (symtab, mle[i].line, mle[i].line + 1, 0);
1469
1470               next_line = mle[i].line + 1;
1471             }
1472
1473           for (pc = mle[i].start_pc; pc < mle[i].end_pc; )
1474             {
1475               QUIT;
1476               fputs_unfiltered ("    ", gdb_stdout);
1477               print_address (pc, gdb_stdout);
1478               fputs_unfiltered (":\t    ", gdb_stdout);
1479               pc += (*tm_print_insn) (pc, &di);
1480               fputs_unfiltered ("\n", gdb_stdout);
1481             }
1482         }
1483     }
1484   else
1485     {
1486 assembly_only:
1487       for (pc = low; pc < high; )
1488         {
1489           QUIT;
1490           fputs_unfiltered ("    ", gdb_stdout);
1491           print_address (pc, gdb_stdout);
1492           fputs_unfiltered (":\t    ", gdb_stdout);
1493           pc += (*tm_print_insn) (pc, &di);
1494           fputs_unfiltered ("\n", gdb_stdout);
1495         }
1496     }
1497
1498   gdb_flush (gdb_stdout);
1499
1500   return TCL_OK;
1501 }
1502 \f
1503 static void
1504 tk_command (cmd, from_tty)
1505      char *cmd;
1506      int from_tty;
1507 {
1508   int retval;
1509   char *result;
1510   struct cleanup *old_chain;
1511
1512   /* Catch case of no argument, since this will make the tcl interpreter dump core. */
1513   if (cmd == NULL)
1514     error_no_arg ("tcl command to interpret");
1515
1516   retval = Tcl_Eval (interp, cmd);
1517
1518   result = strdup (interp->result);
1519
1520   old_chain = make_cleanup (free, result);
1521
1522   if (retval != TCL_OK)
1523     error (result);
1524
1525   printf_unfiltered ("%s\n", result);
1526
1527   do_cleanups (old_chain);
1528 }
1529
1530 static void
1531 cleanup_init (ignored)
1532      int ignored;
1533 {
1534   if (interp != NULL)
1535     Tcl_DeleteInterp (interp);
1536   interp = NULL;
1537 }
1538
1539 /* Come here during long calculations to check for GUI events.  Usually invoked
1540    via the QUIT macro.  */
1541
1542 static void
1543 gdbtk_interactive ()
1544 {
1545   /* Tk_DoOneEvent (TK_DONT_WAIT|TK_IDLE_EVENTS); */
1546 }
1547
1548 /* Come here when there is activity on the X file descriptor. */
1549
1550 static void
1551 x_event (signo)
1552      int signo;
1553 {
1554   /* Process pending events */
1555
1556   while (Tcl_DoOneEvent (TCL_DONT_WAIT|TCL_ALL_EVENTS) != 0);
1557 }
1558
1559 #ifdef __CYGWIN32__
1560
1561 /* For Cygwin32, we use a timer to periodically check for Windows
1562    messages.  FIXME: It would be better to not poll, but to instead
1563    rewrite the target_wait routines to serve as input sources.
1564    Unfortunately, that will be a lot of work.  */
1565
1566 static void
1567 gdbtk_start_timer ()
1568 {
1569   sigset_t nullsigmask;
1570   struct sigaction action;
1571   struct itimerval it;
1572
1573   sigemptyset (&nullsigmask);
1574
1575   action.sa_handler = x_event;
1576   action.sa_mask = nullsigmask;
1577   action.sa_flags = 0;
1578   sigaction (SIGALRM, &action, NULL);
1579
1580   it.it_interval.tv_sec = 0;
1581   /* Check for messages twice a second.  */
1582   it.it_interval.tv_usec = 500 * 1000;
1583   it.it_value.tv_sec = 0;
1584   it.it_value.tv_usec = 500 * 1000;
1585
1586   setitimer (ITIMER_REAL, &it, NULL);
1587 }
1588
1589 static void
1590 gdbtk_stop_timer ()
1591 {
1592   sigset_t nullsigmask;
1593   struct sigaction action;
1594   struct itimerval it;
1595
1596   sigemptyset (&nullsigmask);
1597
1598   action.sa_handler = SIG_IGN;
1599   action.sa_mask = nullsigmask;
1600   action.sa_flags = 0;
1601   sigaction (SIGALRM, &action, NULL);
1602
1603   it.it_interval.tv_sec = 0;
1604   it.it_interval.tv_usec = 0;
1605   it.it_value.tv_sec = 0;
1606   it.it_value.tv_usec = 0;
1607   setitimer (ITIMER_REAL, &it, NULL);
1608 }
1609
1610 #endif
1611
1612 /* This hook function is called whenever we want to wait for the
1613    target.  */
1614
1615 static int
1616 gdbtk_wait (pid, ourstatus)
1617      int pid;
1618      struct target_waitstatus *ourstatus;
1619 {
1620 #ifndef WINNT
1621   struct sigaction action;
1622   static sigset_t nullsigmask = {0};
1623
1624
1625 #ifndef SA_RESTART
1626   /* Needed for SunOS 4.1.x */
1627 #define SA_RESTART 0
1628 #endif
1629
1630   action.sa_handler = x_event;
1631   action.sa_mask = nullsigmask;
1632   action.sa_flags = SA_RESTART;
1633   sigaction(SIGIO, &action, NULL);
1634 #endif /* WINNT */
1635
1636 #ifdef __CYGWIN32__
1637   gdbtk_start_timer ();
1638 #endif
1639
1640   pid = target_wait (pid, ourstatus);
1641
1642 #ifdef __CYGWIN32__
1643   gdbtk_stop_timer ();
1644 #endif
1645
1646 #ifndef WINNT
1647   action.sa_handler = SIG_IGN;
1648   sigaction(SIGIO, &action, NULL);
1649 #endif
1650
1651   return pid;
1652 }
1653
1654 /* This is called from execute_command, and provides a wrapper around
1655    various command routines in a place where both protocol messages and
1656    user input both flow through.  Mostly this is used for indicating whether
1657    the target process is running or not.
1658 */
1659
1660 static void
1661 gdbtk_call_command (cmdblk, arg, from_tty)
1662      struct cmd_list_element *cmdblk;
1663      char *arg;
1664      int from_tty;
1665 {
1666   running_now = 0;
1667   if (cmdblk->class == class_run || cmdblk->class == class_trace)
1668     {
1669       running_now = 1;
1670       Tcl_Eval (interp, "gdbtk_tcl_busy");
1671       (*cmdblk->function.cfunc)(arg, from_tty);
1672       running_now = 0;
1673       Tcl_Eval (interp, "gdbtk_tcl_idle");
1674     }
1675   else
1676     (*cmdblk->function.cfunc)(arg, from_tty);
1677 }
1678
1679 /* This function is called instead of gdb's internal command loop.  This is the
1680    last chance to do anything before entering the main Tk event loop. */
1681
1682 static void
1683 tk_command_loop ()
1684 {
1685   extern GDB_FILE *instream;
1686
1687   /* We no longer want to use stdin as the command input stream */
1688   instream = NULL;
1689
1690   if (Tcl_Eval (interp, "gdbtk_tcl_preloop") != TCL_OK)
1691     {
1692       char *msg;
1693
1694       /* Force errorInfo to be set up propertly.  */
1695       Tcl_AddErrorInfo (interp, "");
1696
1697       msg = Tcl_GetVar (interp, "errorInfo", TCL_GLOBAL_ONLY);
1698 #ifdef _WIN32
1699       MessageBox (NULL, msg, NULL, MB_OK | MB_ICONERROR | MB_TASKMODAL);
1700 #else
1701       fputs_unfiltered (msg, gdb_stderr);
1702 #endif
1703     }
1704
1705 #ifdef _WIN32
1706   close_bfds ();
1707 #endif
1708
1709   Tk_MainLoop ();
1710 }
1711
1712 /* gdbtk_init installs this function as a final cleanup.  */
1713
1714 static void
1715 gdbtk_cleanup (dummy)
1716      PTR dummy;
1717 {
1718   Tcl_Finalize ();
1719 }
1720
1721 /* Initialize gdbtk.  */
1722
1723 static void
1724 gdbtk_init ( argv0 )
1725      char *argv0;
1726 {
1727   struct cleanup *old_chain;
1728   char *lib, *gdbtk_lib, *gdbtk_lib_tmp, *gdbtk_file;
1729   int i, found_main;
1730 #ifndef WINNT
1731   struct sigaction action;
1732   static sigset_t nullsigmask = {0};
1733 #endif
1734 #ifdef IDE
1735   /* start-sanitize-ide */
1736   struct ide_event_handle *h;
1737   const char *errmsg;
1738   char *libexecdir;
1739   /* end-sanitize-ide */
1740 #endif
1741
1742   /* If there is no DISPLAY environment variable, Tk_Init below will fail,
1743      causing gdb to abort.  If instead we simply return here, gdb will
1744      gracefully degrade to using the command line interface. */
1745
1746 #ifndef WINNT
1747   if (getenv ("DISPLAY") == NULL)
1748     return;
1749 #endif
1750
1751   old_chain = make_cleanup (cleanup_init, 0);
1752
1753   /* First init tcl and tk. */
1754   Tcl_FindExecutable (argv0);
1755   interp = Tcl_CreateInterp ();
1756
1757   if (!interp)
1758     error ("Tcl_CreateInterp failed");
1759
1760   if (Tcl_Init(interp) != TCL_OK)
1761     error ("Tcl_Init failed: %s", interp->result);
1762
1763   make_final_cleanup (gdbtk_cleanup, NULL);
1764
1765   /* Initialize the Paths variable.  */
1766   if (ide_initialize_paths (interp, "gdbtcl") != TCL_OK)
1767     error ("ide_initialize_paths failed: %s", interp->result);
1768
1769 #ifdef IDE
1770   /* start-sanitize-ide */
1771   /* Find the directory where we expect to find idemanager.  We ignore
1772      errors since it doesn't really matter if this fails.  */
1773   libexecdir = Tcl_GetVar2 (interp, "Paths", "libexecdir", TCL_GLOBAL_ONLY);
1774
1775   IluTk_Init ();
1776
1777   h = ide_event_init_from_environment (&errmsg, libexecdir);
1778   if (h == NULL)
1779     {
1780       Tcl_AppendResult (interp, "can't initialize event system: ", errmsg,
1781                         (char *) NULL);
1782       fprintf(stderr, "WARNING: ide_event_init_client failed: %s\n", interp->result);
1783
1784       Tcl_SetVar (interp, "GDBTK_IDE", "0", 0);
1785     }
1786   else
1787     {
1788       if (ide_create_tclevent_command (interp, h) != TCL_OK)
1789         error ("ide_create_tclevent_command failed: %s", interp->result);
1790
1791       if (ide_create_edit_command (interp, h) != TCL_OK)
1792         error ("ide_create_edit_command failed: %s", interp->result);
1793
1794       if (ide_create_property_command (interp, h) != TCL_OK)
1795         error ("ide_create_property_command failed: %s", interp->result);
1796
1797       if (ide_create_build_command (interp, h) != TCL_OK)
1798         error ("ide_create_build_command failed: %s", interp->result);
1799
1800       if (ide_create_window_register_command (interp, h, "gdb-restore")
1801           != TCL_OK)
1802         error ("ide_create_window_register_command failed: %s",
1803                interp->result);
1804
1805       if (ide_create_window_command (interp, h) != TCL_OK)
1806         error ("ide_create_window_command failed: %s", interp->result);
1807
1808       if (ide_create_exit_command (interp, h) != TCL_OK)
1809         error ("ide_create_exit_command failed: %s", interp->result);
1810
1811       if (ide_create_help_command (interp) != TCL_OK)
1812         error ("ide_create_help_command failed: %s", interp->result);
1813
1814       /*
1815         if (ide_initialize (interp, "gdb") != TCL_OK)
1816         error ("ide_initialize failed: %s", interp->result);
1817       */
1818
1819       Tcl_SetVar (interp, "GDBTK_IDE", "1", 0);
1820       Tcl_SetVar (interp, "IDE", "1", TCL_GLOBAL_ONLY);
1821     }
1822   /* end-sanitize-ide */
1823 #else
1824   Tcl_SetVar (interp, "GDBTK_IDE", "0", 0);
1825 #endif /* IDE */
1826
1827   /* We don't want to open the X connection until we've done all the
1828      IDE initialization.  Otherwise, goofy looking unfinished windows
1829      pop up when ILU drops into the TCL event loop.  */
1830
1831   if (Tk_Init(interp) != TCL_OK)
1832     error ("Tk_Init failed: %s", interp->result);
1833
1834   if (Itcl_Init(interp) == TCL_ERROR)
1835     error ("Itcl_Init failed: %s", interp->result);
1836
1837   if (Tix_Init(interp) != TCL_OK)
1838     error ("Tix_Init failed: %s", interp->result);
1839
1840 #ifdef __CYGWIN32__
1841   /* On Windows, create a sizebox widget command */
1842   if (ide_create_sizebox_command (interp) != TCL_OK)
1843     error ("sizebox creation failed");
1844   if (ide_create_winprint_command (interp) != TCL_OK)
1845     error ("windows print code initialization failed");
1846   /* start-sanitize-ide */
1847   /* An interface to ShellExecute.  */
1848   if (ide_create_shell_execute_command (interp) != TCL_OK)
1849     error ("shell execute command initialization failed");
1850   /* end-sanitize-ide */
1851 #endif
1852
1853   Tcl_CreateCommand (interp, "gdb_cmd", call_wrapper, gdb_cmd, NULL);
1854   Tcl_CreateCommand (interp, "gdb_loc", call_wrapper, gdb_loc, NULL);
1855   Tcl_CreateCommand (interp, "gdb_path_conv", call_wrapper, gdb_path_conv, NULL);
1856   Tcl_CreateCommand (interp, "gdb_sourcelines", call_wrapper, gdb_sourcelines,
1857                      NULL);
1858   Tcl_CreateCommand (interp, "gdb_listfiles", call_wrapper, gdb_listfiles,
1859                      NULL);
1860   Tcl_CreateCommand (interp, "gdb_listfuncs", call_wrapper, gdb_listfuncs,
1861                      NULL);
1862   Tcl_CreateCommand (interp, "gdb_get_mem", call_wrapper, gdb_get_mem,
1863                      NULL);
1864   Tcl_CreateCommand (interp, "gdb_stop", call_wrapper, gdb_stop, NULL);
1865   Tcl_CreateCommand (interp, "gdb_regnames", call_wrapper, gdb_regnames, NULL);
1866   Tcl_CreateCommand (interp, "gdb_fetch_registers", call_wrapper,
1867                      gdb_fetch_registers, NULL);
1868   Tcl_CreateCommand (interp, "gdb_changed_register_list", call_wrapper,
1869                      gdb_changed_register_list, NULL);
1870   Tcl_CreateCommand (interp, "gdb_disassemble", call_wrapper,
1871                      gdb_disassemble, NULL);
1872   Tcl_CreateCommand (interp, "gdb_eval", call_wrapper, gdb_eval, NULL);
1873   Tcl_CreateCommand (interp, "gdb_get_breakpoint_list", call_wrapper,
1874                      gdb_get_breakpoint_list, NULL);
1875   Tcl_CreateCommand (interp, "gdb_get_breakpoint_info", call_wrapper,
1876                      gdb_get_breakpoint_info, NULL);
1877   Tcl_CreateCommand (interp, "gdb_clear_file", call_wrapper,
1878                      gdb_clear_file, NULL);
1879   Tcl_CreateCommand (interp, "gdb_confirm_quit", call_wrapper,
1880                      gdb_confirm_quit, NULL);
1881   Tcl_CreateCommand (interp, "gdb_force_quit", call_wrapper,
1882                      gdb_force_quit, NULL);
1883   Tcl_CreateCommand (interp, "gdb_target_has_execution",
1884                      gdb_target_has_execution_command,
1885                      NULL, NULL);
1886   Tcl_CreateObjCommand (interp, "gdb_load_info", gdb_load_info, NULL, NULL);
1887   Tcl_CreateObjCommand (interp, "gdb_get_locals", gdb_get_vars_command,
1888                         (ClientData) 0, NULL);
1889   Tcl_CreateObjCommand (interp, "gdb_get_args", gdb_get_vars_command,
1890                         (ClientData) 1, NULL);
1891   Tcl_CreateObjCommand (interp, "gdb_get_function", gdb_get_function_command,
1892                         NULL, NULL);
1893   Tcl_CreateObjCommand (interp, "gdb_get_line", gdb_get_line_command,
1894                         NULL, NULL);
1895   Tcl_CreateObjCommand (interp, "gdb_get_file", gdb_get_file_command,
1896                         NULL, NULL);
1897   Tcl_CreateObjCommand (interp, "gdb_tracepoint_exists",
1898                         gdb_tracepoint_exists_command, NULL, NULL);
1899   Tcl_CreateObjCommand (interp, "gdb_get_tracepoint_info",
1900                         gdb_get_tracepoint_info, NULL, NULL);
1901   Tcl_CreateObjCommand (interp, "gdb_actions",
1902                         gdb_actions_command, NULL, NULL);
1903   Tcl_CreateObjCommand (interp, "gdb_prompt",
1904                         gdb_prompt_command, NULL, NULL);
1905   Tcl_CreateObjCommand (interp, "gdb_find_file",
1906                         gdb_find_file_command, NULL, NULL);
1907   Tcl_CreateObjCommand (interp, "gdb_get_tracepoint_list",
1908                         gdb_get_tracepoint_list, NULL, NULL);
1909
1910   command_loop_hook = tk_command_loop;
1911   print_frame_info_listing_hook =
1912     (void (*) PARAMS ((struct symtab *, int, int, int))) null_routine;
1913   query_hook = gdbtk_query;
1914   flush_hook = gdbtk_flush;
1915   create_breakpoint_hook = gdbtk_create_breakpoint;
1916   delete_breakpoint_hook = gdbtk_delete_breakpoint;
1917   modify_breakpoint_hook = gdbtk_modify_breakpoint;
1918   interactive_hook = gdbtk_interactive;
1919   target_wait_hook = gdbtk_wait;
1920   call_command_hook = gdbtk_call_command;
1921   readline_begin_hook = gdbtk_readline_begin;
1922   readline_hook = gdbtk_readline;
1923   readline_end_hook = gdbtk_readline_end;
1924   ui_load_progress_hook = gdbtk_load_hash;
1925   create_tracepoint_hook = gdbtk_create_tracepoint;
1926   delete_tracepoint_hook = gdbtk_delete_tracepoint;
1927
1928 #ifndef WINNT
1929   /* Get the file descriptor for the X server */
1930
1931   x_fd = ConnectionNumber (Tk_Display (Tk_MainWindow (interp)));
1932
1933   /* Setup for I/O interrupts */
1934
1935   action.sa_mask = nullsigmask;
1936   action.sa_flags = 0;
1937   action.sa_handler = SIG_IGN;
1938   sigaction(SIGIO, &action, NULL);
1939
1940 #ifdef FIOASYNC
1941   i = 1;
1942   if (ioctl (x_fd, FIOASYNC, &i))
1943     perror_with_name ("gdbtk_init: ioctl FIOASYNC failed");
1944
1945 #ifdef SIOCSPGRP
1946   i = getpid();
1947   if (ioctl (x_fd, SIOCSPGRP, &i))
1948     perror_with_name ("gdbtk_init: ioctl SIOCSPGRP failed");
1949
1950 #else
1951 #ifdef F_SETOWN
1952   i = getpid();
1953   if (fcntl (x_fd, F_SETOWN, i))
1954     perror_with_name ("gdbtk_init: fcntl F_SETOWN failed");
1955 #endif  /* F_SETOWN */
1956 #endif  /* !SIOCSPGRP */
1957 #else
1958 #ifndef WINNT
1959   if (ioctl (x_fd,  I_SETSIG, S_INPUT|S_RDNORM) < 0)
1960     perror_with_name ("gdbtk_init: ioctl I_SETSIG failed");
1961 #endif
1962
1963 #endif /* ifndef FIOASYNC */
1964 #endif /* WINNT */
1965
1966   add_com ("tk", class_obscure, tk_command,
1967            "Send a command directly into tk.");
1968
1969   Tcl_LinkVar (interp, "disassemble-from-exec", (char *)&disassemble_from_exec,
1970                TCL_LINK_INT);
1971
1972   /* find the gdb tcl library and source main.tcl */
1973
1974   gdbtk_lib = getenv ("GDBTK_LIBRARY");
1975   if (!gdbtk_lib)
1976     if (access ("gdbtcl/main.tcl", R_OK) == 0)
1977       gdbtk_lib = "gdbtcl";
1978     else
1979       gdbtk_lib = GDBTK_LIBRARY;
1980
1981   gdbtk_lib_tmp = xstrdup (gdbtk_lib);
1982
1983   found_main = 0;
1984   /* see if GDBTK_LIBRARY is a path list */
1985   lib = strtok (gdbtk_lib_tmp, GDBTK_PATH_SEP);
1986   do
1987     {
1988       if (Tcl_VarEval (interp, "lappend auto_path ", lib, NULL) != TCL_OK)
1989         {
1990           fputs_unfiltered (Tcl_GetVar (interp, "errorInfo", 0), gdb_stderr);
1991           error ("");
1992         }
1993       if (!found_main)
1994         {
1995           gdbtk_file = concat (lib, "/main.tcl", (char *) NULL);
1996           if (access (gdbtk_file, R_OK) == 0)
1997             {
1998               found_main++;
1999               Tcl_SetVar (interp, "GDBTK_LIBRARY", lib, 0);
2000             }
2001         }
2002      }
2003   while ((lib = strtok (NULL, ":")) != NULL);
2004
2005   free (gdbtk_lib_tmp);
2006
2007   if (!found_main)
2008     {
2009       /* Try finding it with the auto path.  */
2010
2011       static const char script[] ="\
2012 proc gdbtk_find_main {} {\n\
2013   global auto_path GDBTK_LIBRARY\n\
2014   foreach dir $auto_path {\n\
2015     set f [file join $dir main.tcl]\n\
2016     if {[file exists $f]} then {\n\
2017       set GDBTK_LIBRARY $dir\n\
2018       return $f\n\
2019     }\n\
2020   }\n\
2021   return ""\n\
2022 }\n\
2023 gdbtk_find_main";
2024
2025       if (Tcl_GlobalEval (interp, (char *) script) != TCL_OK)
2026         {
2027           fputs_unfiltered (Tcl_GetVar (interp, "errorInfo", 0), gdb_stderr);
2028           error ("");
2029         }
2030
2031       if (interp->result[0] != '\0')
2032         {
2033           gdbtk_file = xstrdup (interp->result);
2034           found_main++;
2035         }
2036     }
2037
2038   if (!found_main)
2039     {
2040       fputs_unfiltered_hook = NULL; /* Force errors to stdout/stderr */
2041       if (getenv("GDBTK_LIBRARY"))
2042         {
2043           fprintf_unfiltered (stderr, "Unable to find main.tcl in %s\n",getenv("GDBTK_LIBRARY"));
2044           fprintf_unfiltered (stderr,
2045                               "Please set GDBTK_LIBRARY to a path that includes the GDB tcl files.\n");
2046         }
2047       else
2048         {
2049           fprintf_unfiltered (stderr, "Unable to find main.tcl in %s\n", GDBTK_LIBRARY);
2050           fprintf_unfiltered (stderr, "You might want to set GDBTK_LIBRARY\n");
2051         }
2052       error("");
2053     }
2054
2055 /* Defer setup of fputs_unfiltered_hook to near the end so that error messages
2056    prior to this point go to stdout/stderr.  */
2057
2058   fputs_unfiltered_hook = gdbtk_fputs;
2059
2060   if (Tcl_EvalFile (interp, gdbtk_file) != TCL_OK)
2061     {
2062       char *msg;
2063
2064       /* Force errorInfo to be set up propertly.  */
2065       Tcl_AddErrorInfo (interp, "");
2066
2067       msg = Tcl_GetVar (interp, "errorInfo", TCL_GLOBAL_ONLY);
2068
2069       fputs_unfiltered_hook = NULL; /* Force errors to stdout/stderr */
2070
2071 #ifdef _WIN32
2072       MessageBox (NULL, msg, NULL, MB_OK | MB_ICONERROR | MB_TASKMODAL);
2073 #else
2074       fputs_unfiltered (msg, gdb_stderr);
2075 #endif
2076
2077       error ("");
2078     }
2079
2080 #ifdef IDE
2081   /* start-sanitize-ide */
2082   /* Don't do this until we have initialized.  Otherwise, we may get a
2083      run command before we are ready for one.  */
2084   if (ide_run_server_init (interp, h) != TCL_OK)
2085     error ("ide_run_server_init failed: %s", interp->result);
2086   /* end-sanitize-ide */
2087 #endif
2088
2089   free (gdbtk_file);
2090
2091   discard_cleanups (old_chain);
2092 }
2093
2094 static int
2095 gdb_target_has_execution_command (clientData, interp, argc, argv)
2096      ClientData clientData;
2097      Tcl_Interp *interp;
2098      int argc;
2099      char *argv[];
2100 {
2101   int result = 0;
2102
2103   if (target_has_execution && inferior_pid != 0)
2104     result = 1;
2105
2106   Tcl_SetIntObj (Tcl_GetObjResult (interp), result);
2107   return TCL_OK;
2108 }
2109
2110 /* gdb_load_info - returns information about the file about to be downloaded */
2111
2112 static int
2113 gdb_load_info (clientData, interp, objc, objv)
2114      ClientData clientData;
2115      Tcl_Interp *interp;
2116      int objc;
2117      Tcl_Obj *CONST objv[];
2118 {
2119    bfd *loadfile_bfd;
2120    struct cleanup *old_cleanups;
2121    asection *s;
2122    Tcl_Obj *ob[2];
2123    Tcl_Obj *res[16];
2124    int i = 0;
2125
2126    char *filename = Tcl_GetStringFromObj (objv[1], NULL);
2127
2128    loadfile_bfd = bfd_openr (filename, gnutarget);
2129    if (loadfile_bfd == NULL)
2130      {
2131        Tcl_SetObjResult (interp, Tcl_NewStringObj ("Open failed", -1));
2132        return TCL_ERROR;
2133      }
2134    old_cleanups = make_cleanup (bfd_close, loadfile_bfd);
2135
2136    if (!bfd_check_format (loadfile_bfd, bfd_object))
2137      {
2138        Tcl_SetObjResult (interp, Tcl_NewStringObj ("Bad Object File", -1));
2139        return TCL_ERROR;
2140     }
2141
2142    for (s = loadfile_bfd->sections; s; s = s->next)
2143      {
2144        if (s->flags & SEC_LOAD)
2145          {
2146            bfd_size_type size = bfd_get_section_size_before_reloc (s);
2147            if (size > 0)
2148              {
2149                ob[0] = Tcl_NewStringObj((char *)bfd_get_section_name(loadfile_bfd, s), -1);
2150                ob[1] = Tcl_NewLongObj ((long)size);
2151                res[i++] = Tcl_NewListObj (2, ob);
2152              }
2153          }
2154      }
2155
2156    Tcl_SetObjResult (interp, Tcl_NewListObj (i, res));
2157    do_cleanups (old_cleanups);
2158    return TCL_OK;
2159 }
2160
2161
2162 int
2163 gdbtk_load_hash (section, num)
2164      char *section;
2165      unsigned long num;
2166 {
2167   int result;
2168   char buf[128];
2169   sprintf (buf, "download_hash %s %ld", section, num);
2170   result = Tcl_Eval (interp, buf);
2171   return result;
2172 }
2173
2174 /* gdb_get_vars_command -
2175  *
2176  * Implements the "gdb_get_locals" and "gdb_get_args" tcl commands. This
2177  * function sets the Tcl interpreter's result to a list of variable names
2178  * depending on clientData. If clientData is one, the result is a list of
2179  * arguments; zero returns a list of locals -- all relative to the block
2180  * specified as an argument to the command. Valid commands include
2181  * anything decode_line_1 can handle (like "main.c:2", "*0x02020202",
2182  * and "main").
2183  */
2184 static int
2185 gdb_get_vars_command (clientData, interp, objc, objv)
2186      ClientData clientData;
2187      Tcl_Interp *interp;
2188      int objc;
2189      Tcl_Obj *CONST objv[];
2190 {
2191   Tcl_Obj *result;
2192   struct symtabs_and_lines sals;
2193   struct symbol *sym;
2194   struct block *block;
2195   char **canonical, *args;
2196   int i, nsyms, arguments;
2197
2198   if (objc != 2)
2199     {
2200       Tcl_AppendResult (interp,
2201                         "wrong # of args: should be \"",
2202                         Tcl_GetStringFromObj (objv[0], NULL),
2203                         " function:line|function|line|*addr\"");
2204       return TCL_ERROR;
2205     }
2206
2207   arguments = (int) clientData;
2208   args = Tcl_GetStringFromObj (objv[1], NULL);
2209   sals = decode_line_1 (&args, 1, NULL, 0, &canonical);
2210   if (sals.nelts == 0)
2211     {
2212       Tcl_AppendResult (interp,
2213                         "error decoding line", NULL);
2214       return TCL_ERROR;
2215     }
2216
2217   /* Initialize a list that will hold the results */
2218   result = Tcl_NewListObj (0, NULL);
2219
2220   /* Resolve all line numbers to PC's */
2221   for (i = 0; i < sals.nelts; i++)
2222     resolve_sal_pc (&sals.sals[i]);
2223
2224   block = block_for_pc (sals.sals[0].pc);
2225   while (block != 0)
2226     {
2227       nsyms = BLOCK_NSYMS (block);
2228       for (i = 0; i < nsyms; i++)
2229         {
2230           sym = BLOCK_SYM (block, i);
2231           switch (SYMBOL_CLASS (sym)) {
2232           default:
2233           case LOC_UNDEF:                 /* catches errors        */
2234           case LOC_CONST:             /* constant              */
2235           case LOC_STATIC:            /* static                */
2236           case LOC_REGISTER:      /* register              */
2237           case LOC_TYPEDEF:           /* local typedef         */
2238           case LOC_LABEL:             /* local label           */
2239           case LOC_BLOCK:             /* local function        */
2240           case LOC_CONST_BYTES:   /* loc. byte seq.        */
2241           case LOC_UNRESOLVED:    /* unresolved static     */
2242           case LOC_OPTIMIZED_OUT: /* optimized out         */
2243             break;
2244           case LOC_ARG:               /* argument              */
2245           case LOC_REF_ARG:           /* reference arg         */
2246           case LOC_REGPARM:           /* register arg          */
2247           case LOC_REGPARM_ADDR:  /* indirect register arg */
2248           case LOC_LOCAL_ARG:     /* stack arg             */
2249           case LOC_BASEREG_ARG:   /* basereg arg           */
2250             if (arguments)
2251               Tcl_ListObjAppendElement (interp, result,
2252                                         Tcl_NewStringObj (SYMBOL_NAME (sym), -1));
2253             break;
2254           case LOC_LOCAL:             /* stack local           */
2255           case LOC_BASEREG:           /* basereg local         */
2256             if (!arguments)
2257               Tcl_ListObjAppendElement (interp, result,
2258                                         Tcl_NewStringObj (SYMBOL_NAME (sym), -1));
2259             break;
2260           }
2261         }
2262       if (BLOCK_FUNCTION (block))
2263         break;
2264       else
2265         block = BLOCK_SUPERBLOCK (block);
2266     }
2267
2268   Tcl_SetObjResult (interp, result);
2269   return TCL_OK;
2270 }
2271
2272 static int
2273 gdb_get_line_command (clientData, interp, objc, objv)
2274      ClientData clientData;
2275      Tcl_Interp *interp;
2276      int objc;
2277      Tcl_Obj *CONST objv[];
2278 {
2279   Tcl_Obj *result;
2280   struct symtabs_and_lines sals;
2281   char *args, **canonical;
2282
2283   if (objc != 2)
2284     {
2285       Tcl_AppendResult (interp, "wrong # of args: should be \"",
2286                         Tcl_GetStringFromObj (objv[0], NULL),
2287                         " linespec\"");
2288       return TCL_ERROR;
2289     }
2290
2291   args = Tcl_GetStringFromObj (objv[1], NULL);
2292   sals = decode_line_1 (&args, 1, NULL, 0, &canonical);
2293   if (sals.nelts == 1)
2294     {
2295       Tcl_SetObjResult (interp, Tcl_NewIntObj (sals.sals[0].line));
2296       return TCL_OK;
2297     }
2298
2299     Tcl_SetResult (interp, "N/A", TCL_STATIC);
2300     return TCL_OK;
2301 }
2302
2303 static int
2304 gdb_get_file_command (clientData, interp, objc, objv)
2305      ClientData clientData;
2306      Tcl_Interp *interp;
2307      int objc;
2308      Tcl_Obj *CONST objv[];
2309 {
2310   Tcl_Obj *result;
2311   struct symtabs_and_lines sals;
2312   char *args, **canonical;
2313
2314   if (objc != 2)
2315     {
2316       Tcl_AppendResult (interp, "wrong # of args: should be \"",
2317                         Tcl_GetStringFromObj (objv[0], NULL),
2318                         " linespec\"");
2319       return TCL_ERROR;
2320     }
2321
2322   args = Tcl_GetStringFromObj (objv[1], NULL);
2323   sals = decode_line_1 (&args, 1, NULL, 0, &canonical);
2324   if (sals.nelts == 1)
2325     {
2326       Tcl_SetResult (interp, sals.sals[0].symtab->filename, TCL_VOLATILE);
2327       return TCL_OK;
2328     }
2329
2330     Tcl_SetResult (interp, "N/A", TCL_STATIC);
2331     return TCL_OK;
2332 }
2333
2334 static int
2335 gdb_get_function_command (clientData, interp, objc, objv)
2336      ClientData clientData;
2337      Tcl_Interp *interp;
2338      int objc;
2339      Tcl_Obj *CONST objv[];
2340 {
2341   Tcl_Obj *result;
2342   char *function;
2343   struct symtabs_and_lines sals;
2344   char *args, **canonical;
2345
2346   if (objc != 2)
2347     {
2348       Tcl_AppendResult (interp, "wrong # of args: should be \"",
2349                         Tcl_GetStringFromObj (objv[0], NULL),
2350                         " linespec\"");
2351       return TCL_ERROR;
2352     }
2353
2354   args = Tcl_GetStringFromObj (objv[1], NULL);
2355   sals = decode_line_1 (&args, 1, NULL, 0, &canonical);
2356   if (sals.nelts == 1)
2357     {
2358       resolve_sal_pc (&sals.sals[0]);
2359       find_pc_partial_function (sals.sals[0].pc, &function, NULL, NULL);
2360       if (function != NULL)
2361         {
2362           Tcl_SetResult (interp, function, TCL_VOLATILE);
2363           return TCL_OK;
2364         }
2365     }
2366
2367   Tcl_SetResult (interp, "N/A", TCL_STATIC);
2368   return TCL_OK;
2369 }
2370
2371 static int
2372 gdb_get_tracepoint_info (clientData, interp, objc, objv)
2373      ClientData clientData;
2374      Tcl_Interp *interp;
2375      int objc;
2376      Tcl_Obj  *CONST objv[];
2377 {
2378   struct symtab_and_line sal;
2379   int tpnum;
2380   struct tracepoint *tp;
2381   struct action_line *al;
2382   Tcl_Obj *list, *action_list;
2383   char *filename, *funcname;
2384   char tmp[19];
2385
2386   if (objc != 2)
2387     error ("wrong # args");
2388
2389   Tcl_GetIntFromObj (NULL, objv[1], &tpnum);
2390
2391   ALL_TRACEPOINTS (tp)
2392     if (tp->number == tpnum)
2393       break;
2394
2395   if (tp == NULL)
2396     error ("Tracepoint #%d does not exist", tpnum);
2397
2398   list = Tcl_NewListObj (0, NULL);
2399   sal = find_pc_line (tp->address, 0);
2400   filename = symtab_to_filename (sal.symtab);
2401   if (filename == NULL)
2402     filename = "N/A";
2403   Tcl_ListObjAppendElement (interp, list,
2404                             Tcl_NewStringObj (filename, -1));
2405   find_pc_partial_function (tp->address, &funcname, NULL, NULL);
2406   Tcl_ListObjAppendElement (interp, list, Tcl_NewStringObj (funcname, -1));
2407   Tcl_ListObjAppendElement (interp, list, Tcl_NewIntObj (sal.line));
2408   sprintf (tmp, "0x%08x", tp->address);
2409   Tcl_ListObjAppendElement (interp, list, Tcl_NewStringObj (tmp, -1));
2410   Tcl_ListObjAppendElement (interp, list, Tcl_NewIntObj (tp->enabled));
2411   Tcl_ListObjAppendElement (interp, list, Tcl_NewIntObj (tp->pass_count));
2412   Tcl_ListObjAppendElement (interp, list, Tcl_NewIntObj (tp->step_count));
2413   Tcl_ListObjAppendElement (interp, list, Tcl_NewIntObj (tp->thread));
2414   Tcl_ListObjAppendElement (interp, list, Tcl_NewIntObj (tp->hit_count));
2415
2416   /* Append a list of actions */
2417   action_list = Tcl_NewListObj (0, NULL);
2418   for (al = tp->actions; al != NULL; al = al->next)
2419     {
2420       Tcl_ListObjAppendElement (interp, action_list,
2421                                 Tcl_NewStringObj (al->action, -1));
2422     }
2423   Tcl_ListObjAppendElement (interp, list, action_list);
2424
2425   Tcl_SetObjResult (interp, list);
2426   return TCL_OK;
2427 }
2428
2429 static void
2430 gdbtk_create_tracepoint (tp)
2431   struct tracepoint *tp;
2432 {
2433   tracepoint_notify (tp, "create");
2434 }
2435
2436 static void
2437 gdbtk_delete_tracepoint (tp)
2438   struct tracepoint *tp;
2439 {
2440   tracepoint_notify (tp, "delete");
2441 }
2442
2443 static void
2444 tracepoint_notify(tp, action)
2445      struct tracepoint *tp;
2446      const char *action;
2447 {
2448   char buf[256];
2449   int v;
2450   struct symtab_and_line sal;
2451   char *filename;
2452
2453   /* We ensure that ACTION contains no special Tcl characters, so we
2454      can do this.  */
2455   sal = find_pc_line (tp->address, 0);
2456
2457   filename = symtab_to_filename (sal.symtab);
2458   if (filename == NULL)
2459     filename = "N/A";
2460   sprintf (buf, "gdbtk_tcl_tracepoint %s %d 0x%lx %d {%s}", action, tp->number,
2461            (long)tp->address, sal.line, filename);
2462
2463   v = Tcl_Eval (interp, buf);
2464
2465   if (v != TCL_OK)
2466     {
2467       gdbtk_fputs (interp->result, gdb_stdout);
2468       gdbtk_fputs ("\n", gdb_stdout);
2469     }
2470 }
2471
2472 /* returns -1 if not found, tracepoint # if found */
2473 int
2474 tracepoint_exists (char * args)
2475 {
2476   struct tracepoint *tp;
2477   char **canonical;
2478   struct symtabs_and_lines sals;
2479   char  *file = NULL;
2480   int    result = -1;
2481
2482   sals = decode_line_1 (&args, 1, NULL, 0, &canonical);
2483   if (sals.nelts == 1)
2484     {
2485       resolve_sal_pc (&sals.sals[0]);
2486       file = xmalloc (strlen (sals.sals[0].symtab->dirname)
2487                       + strlen (sals.sals[0].symtab->filename) + 1);
2488       if (file != NULL)
2489         {
2490           strcpy (file, sals.sals[0].symtab->dirname);
2491           strcat (file, sals.sals[0].symtab->filename);
2492
2493           ALL_TRACEPOINTS (tp)
2494             {
2495               if (tp->address == sals.sals[0].pc)
2496                 result = tp->number;
2497               else if (tp->source_file != NULL
2498                        && strcmp (tp->source_file, file) == 0
2499                        && sals.sals[0].line == tp->line_number)
2500
2501                 result = tp->number;
2502             }
2503         }
2504     }
2505   if (file != NULL)
2506     free (file);
2507   return result;
2508 }
2509
2510 static int
2511 gdb_actions_command (clientData, interp, objc, objv)
2512   ClientData clientData;
2513   Tcl_Interp *interp;
2514   int objc;
2515   Tcl_Obj *CONST objv[];
2516 {
2517   struct tracepoint *tp;
2518   Tcl_Obj **actions;
2519   int      nactions, i, len;
2520   char *number, *args, *action;
2521   struct action_line *next = NULL, *temp;
2522
2523   if (objc != 3)
2524     {
2525       Tcl_AppendResult (interp, "wrong # args: should be: \"",
2526                         Tcl_GetStringFromObj (objv[0], NULL),
2527                         " number actions\"");
2528       return TCL_ERROR;
2529     }
2530
2531   args = number = Tcl_GetStringFromObj (objv[1], NULL);
2532   tp = get_tracepoint_by_number (&args);
2533   if (tp == NULL)
2534     {
2535       Tcl_AppendResult (interp, "Tracepoint \"", number, "\" does not exist");
2536       return TCL_ERROR;
2537     }
2538
2539   /* Free any existing actions */
2540   for (temp = tp->actions; temp != NULL; temp = temp->next)
2541     {
2542       if (temp->action)
2543         free (temp->action);
2544       free (temp);
2545     }
2546
2547   Tcl_ListObjGetElements (interp, objv[2], &nactions, &actions);
2548   for (i = 0; i < nactions; i++)
2549     {
2550       temp = xmalloc (sizeof (struct action_line));
2551       temp->next = NULL;
2552       action = Tcl_GetStringFromObj (actions[i], &len);
2553       temp->action = savestring (action, len);
2554       if (next == NULL)
2555         {
2556           tp->actions = temp;
2557           next = temp;
2558         }
2559       else
2560         {
2561           next->next = temp;
2562           next = temp;
2563         }
2564     }
2565
2566   return TCL_OK;
2567 }
2568
2569 static int
2570 gdb_tracepoint_exists_command (clientData, interp, objc, objv)
2571   ClientData clientData;
2572   Tcl_Interp *interp;
2573   int objc;
2574   Tcl_Obj *CONST objv[];
2575 {
2576   char * args;
2577
2578   if (objc != 2)
2579     {
2580       Tcl_AppendResult (interp, "wrong # of args: should be \"",
2581                         Tcl_GetStringFromObj (objv[0], NULL),
2582                         " function:line|function|line|*addr\"");
2583       return TCL_ERROR;
2584     }
2585
2586   args = Tcl_GetStringFromObj (objv[1], NULL);
2587
2588   Tcl_SetObjResult (interp, Tcl_NewIntObj (tracepoint_exists (args)));
2589   return TCL_OK;
2590 }
2591
2592 /* Return the prompt to the interpreter */
2593 static int
2594 gdb_prompt_command (clientData, interp, objc, objv)
2595   ClientData clientData;
2596   Tcl_Interp *interp;
2597   int objc;
2598   Tcl_Obj *CONST objv[];
2599 {
2600   Tcl_SetResult (interp, get_prompt (), TCL_VOLATILE);
2601   return TCL_OK;
2602 }
2603
2604 /* return a list of all tracepoint numbers in interpreter */
2605 static int
2606 gdb_get_tracepoint_list (clientData, interp, objc, objv)
2607   ClientData clientData;
2608   Tcl_Interp *interp;
2609   int objc;
2610   Tcl_Obj *CONST objv[];
2611 {
2612   Tcl_Obj *list;
2613   struct tracepoint *tp;
2614
2615   list = Tcl_NewListObj (0, NULL);
2616
2617   ALL_TRACEPOINTS (tp)
2618     Tcl_ListObjAppendElement (interp, list, Tcl_NewIntObj (tp->number));
2619
2620   Tcl_SetObjResult (interp, list);
2621   return TCL_OK;
2622 }
2623
2624 /* This is stolen from source.c */
2625 #ifdef CRLF_SOURCE_FILES
2626
2627 /* Define CRLF_SOURCE_FILES in an xm-*.h file if source files on the
2628    host use \r\n rather than just \n.  Defining CRLF_SOURCE_FILES is
2629    much faster than defining LSEEK_NOT_LINEAR.  */
2630
2631 #ifndef O_BINARY
2632 #define O_BINARY 0
2633 #endif
2634
2635 #define OPEN_MODE (O_RDONLY | O_BINARY)
2636
2637 #else /* ! defined (CRLF_SOURCE_FILES) */
2638
2639 #define OPEN_MODE O_RDONLY
2640
2641 #endif /* ! defined (CRLF_SOURCE_FILES) */
2642
2643 /* Find the pathname to a file, searching the source_dir */
2644 /* we may actually need to use openp to find the the full pathname
2645    so we don't have any "../" et al in it. */
2646 static int
2647 gdb_find_file_command (clientData, interp, objc, objv)
2648   ClientData clientData;
2649   Tcl_Interp *interp;
2650   int objc;
2651   Tcl_Obj *CONST objv[];
2652 {
2653   char *file, *filename;
2654   struct symtab *st = NULL;
2655
2656   if (objc != 2)
2657     {
2658       Tcl_AppendResult (interp, "wrong # of args: should be \"",
2659                         Tcl_GetStringFromObj (objv[0], NULL),
2660                         " filename\"");
2661       return TCL_ERROR;
2662     }
2663
2664   /* try something simple first */
2665   file  = Tcl_GetStringFromObj (objv[1], NULL);
2666   if (access (file, R_OK) == 0)
2667     {
2668       Tcl_SetObjResult (interp, Tcl_NewStringObj (file, -1));
2669       return TCL_OK;
2670     }
2671
2672   /* We really need a symtab for this to work... */
2673   st = lookup_symtab (file);
2674   if (st != NULL)
2675     {
2676       filename = symtab_to_filename (st);
2677       if (filename != NULL)
2678         {
2679           Tcl_SetObjResult (interp, Tcl_NewStringObj (filename, -1));
2680           return TCL_OK;
2681         }
2682     }
2683
2684   Tcl_SetResult (interp, "", TCL_STATIC);
2685   return TCL_OK;
2686 }
2687
2688 /* Come here during initialize_all_files () */
2689
2690 void
2691 _initialize_gdbtk ()
2692 {
2693   if (use_windows)
2694     {
2695       /* Tell the rest of the world that Gdbtk is now set up. */
2696
2697       init_ui_hook = gdbtk_init;
2698     }
2699 }