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