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