gdb/gdbtk-cmds.c

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