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