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