gdb/gdbtk.c

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