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