gdb/gdbtk/generic/gdbtk-cmds.c

   1 /* Tcl/Tk command definitions for Insight.
   2    Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2001, 2002, 2003, 2004, 2007, 2008
   3    Free Software Foundation, Inc.
   4
   5    Written by Stu Grossman <grossman@cygnus.com> of Cygnus Support.
   6    Substantially augmented by Martin Hunt, Keith Seitz & Jim Ingham of
   7    Cygnus Support.
   8
   9    This file is part of GDB.
  10
  11    This program is free software; you can redistribute it and/or modify
  12    it under the terms of the GNU General Public License as published by
  13    the Free Software Foundation; either version 2 of the License, or
  14    (at your option) any later version.
  15
  16    This program is distributed in the hope that it will be useful,
  17    but WITHOUT ANY WARRANTY; without even the implied warranty of
  18    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19    GNU General Public License for more details.
  20
  21    You should have received a copy of the GNU General Public License
  22    along with this program; if not, write to the Free Software
  23    Foundation, Inc., 51 Franklin Street, Fifth Floor,
  24    Boston, MA 02110-1301, USA.  */
  25
  26 #include "defs.h"
  27 #include "inferior.h"
  28 #include "source.h"
  29 #include "symfile.h"
  30 #include "objfiles.h"
  31 #include "gdbcore.h"
  32 #include "demangle.h"
  33 #include "linespec.h"
  34 #include "tui/tui-file.h"
  35 #include "top.h"
  36 #include "annotate.h"
  37 #include "block.h"
  38 #include "dictionary.h"
  39 #include "filenames.h"
  40 #include "disasm.h"
  41 #include "value.h"
  42 #include "varobj.h"
  43 #include "exceptions.h"
  44 #include "language.h"
  45 #include "target.h"
  46
  47 /* tcl header files includes varargs.h unless HAS_STDARG is defined,
  48    but gdb uses stdarg.h, so make sure HAS_STDARG is defined.  */
  49 #define HAS_STDARG 1
  50
  51 #include <tcl.h>
  52 #include <tk.h>
  53
  54 #include "guitcl.h"
  55 #include "gdbtk.h"
  56 #include "gdbtk-wrapper.h"
  57 #include "gdbtk-cmds.h"
  58
  59 #include <signal.h>
  60 #include <fcntl.h>
  61 #ifdef HAVE_SYS_IOCTL_H
  62 #include <sys/ioctl.h>
  63 #endif
  64 #include <sys/time.h>
  65 #include <sys/stat.h>
  66
  67 #include "gdb_string.h"
  68 #include "dis-asm.h"
  69 #include "gdbcmd.h"
  70
  71 #ifdef __CYGWIN__
  72 #include <sys/cygwin.h>         /* for cygwin_conv_to_full_win32_path */
  73 #endif
  74
  75 #ifdef HAVE_CTYPE_H
  76 #include <ctype.h>              /* for isprint() */
  77 #endif
  78
  79 /* Various globals we reference.  */
  80 extern char *source_path;
  81
  82 /* These two objects hold boolean true and false,
  83    and are shared by all the list objects that gdb_listfuncs
  84    returns. */
  85
  86 static Tcl_Obj *mangled, *not_mangled;
  87
  88 /* These two control how the GUI behaves when gdb is either tracing or loading.
  89    They are used in this file & gdbtk_hooks.c */
  90
  91 int No_Update = 0;
  92 int load_in_progress = 0;
  93
  94 /* This Structure is used in gdb_disassemble_driver.
  95    We need a different sort of line table from the normal one cuz we can't
  96    depend upon implicit line-end pc's for lines to do the
  97    reordering in this function.  */
  98
  99 struct my_line_entry
 100 {
 101   int line;
 102   CORE_ADDR start_pc;
 103   CORE_ADDR end_pc;
 104 };
 105
 106 /* Use this to pass the Tcl Text widget command and the open file
 107    descriptor to the disassembly load command. */
 108
 109 struct disassembly_client_data
 110 {
 111   FILE *fp;
 112   int file_opened_p;
 113   int widget_line_no;
 114   Tcl_Interp *interp;
 115   char *widget;
 116   Tcl_Obj *result_obj[3];
 117   const char *asm_argv[14];
 118   const char *source_argv[7];
 119   char *map_arr;
 120   Tcl_DString src_to_line_prefix;
 121   Tcl_DString pc_to_line_prefix;
 122   Tcl_DString line_to_pc_prefix;
 123   Tcl_CmdInfo cmd;
 124 };
 125
 126 /* This variable determines where memory used for disassembly is read
 127    from.  See note in gdbtk.h for details.  */
 128 /* NOTE: cagney/2003-09-08: This variable is unused.  */
 129 int disassemble_from_exec = -1;
 130
 131 extern int gdb_variable_init (Tcl_Interp * interp);
 132
 133 /*
 134  * Declarations for routines exported from this file
 135  */
 136
 137 int Gdbtk_Init (Tcl_Interp * interp);
 138
 139 /*
 140  * Declarations for routines used only in this file.
 141  */
 142
 143 static int compare_lines (const PTR, const PTR);
 144 static int comp_files (const void *, const void *);
 145 static int gdb_clear_file (ClientData, Tcl_Interp * interp, int,
 146                            Tcl_Obj * CONST[]);
 147 static int gdb_cmd (ClientData, Tcl_Interp *, int, Tcl_Obj * CONST[]);
 148 static int gdb_confirm_quit (ClientData, Tcl_Interp *, int,
 149                              Tcl_Obj * CONST[]);
 150 static int gdb_entry_point (ClientData, Tcl_Interp *, int, Tcl_Obj * CONST[]);
 151 static int gdb_eval (ClientData, Tcl_Interp *, int, Tcl_Obj * CONST[]);
 152 static int gdb_find_file_command (ClientData, Tcl_Interp *, int,
 153                                   Tcl_Obj * CONST objv[]);
 154 static int gdb_force_quit (ClientData, Tcl_Interp *, int, Tcl_Obj * CONST[]);
 155 static int gdb_get_file_command (ClientData, Tcl_Interp *, int,
 156                                  Tcl_Obj * CONST objv[]);
 157 static int gdb_get_function_command (ClientData, Tcl_Interp *, int,
 158                                      Tcl_Obj * CONST objv[]);
 159 static int gdb_get_line_command (ClientData, Tcl_Interp *, int,
 160                                  Tcl_Obj * CONST objv[]);
 161 static int gdb_update_mem (ClientData, Tcl_Interp *, int, Tcl_Obj * CONST[]);
 162 static int gdb_set_mem (ClientData, Tcl_Interp *, int, Tcl_Obj * CONST[]);
 163 static int gdb_immediate_command (ClientData, Tcl_Interp *, int,
 164                                   Tcl_Obj * CONST[]);
 165 static int gdb_incr_addr (ClientData, Tcl_Interp *, int, Tcl_Obj * CONST[]);
 166 static int gdb_CA_to_TAS (ClientData, Tcl_Interp *, int, Tcl_Obj * CONST[]);
 167 static int gdb_listfiles (ClientData, Tcl_Interp *, int, Tcl_Obj * CONST[]);
 168 static int gdb_listfuncs (ClientData, Tcl_Interp *, int, Tcl_Obj * CONST[]);
 169 static int gdb_loadfile (ClientData, Tcl_Interp *, int,
 170                          Tcl_Obj * CONST objv[]);
 171 static int gdb_load_disassembly (ClientData clientData, Tcl_Interp
 172                                  * interp, int objc, Tcl_Obj * CONST objv[]);
 173 static int gdb_get_inferior_args (ClientData clientData,
 174                                   Tcl_Interp *interp,
 175                                   int objc, Tcl_Obj * CONST objv[]);
 176 static int gdb_set_inferior_args (ClientData clientData,
 177                                   Tcl_Interp *interp,
 178                                   int objc, Tcl_Obj * CONST objv[]);
 179 static int gdb_load_info (ClientData, Tcl_Interp *, int,
 180                           Tcl_Obj * CONST objv[]);
 181 static int gdb_loc (ClientData, Tcl_Interp *, int, Tcl_Obj * CONST[]);
 182 static int gdb_path_conv (ClientData, Tcl_Interp *, int, Tcl_Obj * CONST[]);
 183 static int gdb_prompt_command (ClientData, Tcl_Interp *, int,
 184                                Tcl_Obj * CONST objv[]);
 185 static int gdb_restore_fputs (ClientData, Tcl_Interp *, int,
 186                               Tcl_Obj * CONST[]);
 187 static int gdb_search (ClientData, Tcl_Interp *, int, Tcl_Obj * CONST objv[]);
 188 static int gdb_stop (ClientData, Tcl_Interp *, int, Tcl_Obj * CONST[]);
 189 static int gdb_target_has_execution_command (ClientData,
 190                                              Tcl_Interp *, int,
 191                                              Tcl_Obj * CONST[]);
 192 static void gdbtk_load_source (ClientData clientData,
 193                                struct symtab *symtab,
 194                                int start_line, int end_line);
 195 static CORE_ADDR gdbtk_load_asm (ClientData clientData, CORE_ADDR pc,
 196                                  struct disassemble_info *di);
 197 static int gdb_disassemble_driver (CORE_ADDR low, CORE_ADDR high,
 198                                    int mixed_source_and_assembly,
 199                                    ClientData clientData,
 200                                    void (*print_source_fn) (ClientData, struct
 201                                                             symtab *, int,
 202                                                             int),
 203                                    CORE_ADDR (*print_asm_fn) (ClientData,
 204                                                               CORE_ADDR,
 205                                                               struct
 206                                                               disassemble_info
 207                                                               *));
 208 char *get_prompt (void);
 209 static int perror_with_name_wrapper (PTR args);
 210 static int wrapped_call (PTR opaque_args);
 211 static int hex2bin (const char *hex, char *bin, int count);
 212 static int fromhex (int a);
 213 \f
 214
 215 /* Gdbtk_Init
 216  *    This loads all the Tcl commands into the Tcl interpreter.
 217  *
 218  * Arguments:
 219  *    interp - The interpreter into which to load the commands.
 220  *
 221  * Result:
 222  *     A standard Tcl result.
 223  */
 224
 225 int
 226 Gdbtk_Init (Tcl_Interp *interp)
 227 {
 228   Tcl_CreateObjCommand (interp, "gdb_cmd", gdbtk_call_wrapper, gdb_cmd, NULL);
 229   Tcl_CreateObjCommand (interp, "gdb_immediate", gdbtk_call_wrapper,
 230                         gdb_immediate_command, NULL);
 231   Tcl_CreateObjCommand (interp, "gdb_loc", gdbtk_call_wrapper, gdb_loc, NULL);
 232   Tcl_CreateObjCommand (interp, "gdb_path_conv", gdbtk_call_wrapper, gdb_path_conv,
 233                         NULL);
 234   Tcl_CreateObjCommand (interp, "gdb_listfiles", gdbtk_call_wrapper, gdb_listfiles,
 235                         NULL);
 236   Tcl_CreateObjCommand (interp, "gdb_listfuncs", gdbtk_call_wrapper, gdb_listfuncs,
 237                         NULL);
 238   Tcl_CreateObjCommand (interp, "gdb_entry_point", gdbtk_call_wrapper,
 239                         gdb_entry_point, NULL);
 240   Tcl_CreateObjCommand (interp, "gdb_update_mem", gdbtk_call_wrapper, gdb_update_mem,
 241                         NULL);
 242   Tcl_CreateObjCommand (interp, "gdb_set_mem", gdbtk_call_wrapper, gdb_set_mem,
 243                         NULL);
 244   Tcl_CreateObjCommand (interp, "gdb_stop", gdbtk_call_wrapper, gdb_stop, NULL);
 245   Tcl_CreateObjCommand (interp, "gdb_restore_fputs", gdbtk_call_wrapper, gdb_restore_fputs,
 246                         NULL);
 247   Tcl_CreateObjCommand (interp, "gdb_eval", gdbtk_call_wrapper, gdb_eval, NULL);
 248   Tcl_CreateObjCommand (interp, "gdb_incr_addr", gdbtk_call_wrapper, gdb_incr_addr, NULL);
 249   Tcl_CreateObjCommand (interp, "gdb_CA_to_TAS", gdbtk_call_wrapper, gdb_CA_to_TAS, NULL);
 250   Tcl_CreateObjCommand (interp, "gdb_clear_file", gdbtk_call_wrapper,
 251                         gdb_clear_file, NULL);
 252   Tcl_CreateObjCommand (interp, "gdb_confirm_quit", gdbtk_call_wrapper,
 253                         gdb_confirm_quit, NULL);
 254   Tcl_CreateObjCommand (interp, "gdb_force_quit", gdbtk_call_wrapper,
 255                         gdb_force_quit, NULL);
 256   Tcl_CreateObjCommand (interp, "gdb_target_has_execution",
 257                         gdbtk_call_wrapper,
 258                         gdb_target_has_execution_command, NULL);
 259   Tcl_CreateObjCommand (interp, "gdb_load_info", gdbtk_call_wrapper, gdb_load_info,
 260                         NULL);
 261   Tcl_CreateObjCommand (interp, "gdb_get_function", gdbtk_call_wrapper,
 262                         gdb_get_function_command, NULL);
 263   Tcl_CreateObjCommand (interp, "gdb_get_line", gdbtk_call_wrapper,
 264                         gdb_get_line_command, NULL);
 265   Tcl_CreateObjCommand (interp, "gdb_get_file", gdbtk_call_wrapper,
 266                         gdb_get_file_command, NULL);
 267   Tcl_CreateObjCommand (interp, "gdb_prompt",
 268                         gdbtk_call_wrapper, gdb_prompt_command, NULL);
 269   Tcl_CreateObjCommand (interp, "gdb_find_file",
 270                         gdbtk_call_wrapper, gdb_find_file_command, NULL);
 271   Tcl_CreateObjCommand (interp, "gdb_loadfile", gdbtk_call_wrapper, gdb_loadfile,
 272                         NULL);
 273   Tcl_CreateObjCommand (interp, "gdb_load_disassembly", gdbtk_call_wrapper,
 274                         gdb_load_disassembly,  NULL);
 275   Tcl_CreateObjCommand (gdbtk_interp, "gdb_search", gdbtk_call_wrapper,
 276                         gdb_search, NULL);
 277   Tcl_CreateObjCommand (interp, "gdb_get_inferior_args", gdbtk_call_wrapper,
 278                         gdb_get_inferior_args, NULL);
 279   Tcl_CreateObjCommand (interp, "gdb_set_inferior_args", gdbtk_call_wrapper,
 280                         gdb_set_inferior_args, NULL);
 281
 282   /* gdb_context is used for debugging multiple threads or tasks */
 283   Tcl_LinkVar (interp, "gdb_context_id",
 284                (char *) &gdb_context,
 285                TCL_LINK_INT | TCL_LINK_READ_ONLY);
 286
 287   /* Make gdb's notion of the pwd visible.  This is read-only because
 288      (1) it doesn't make sense to change it directly and (2) it is
 289      allocated using xmalloc and not Tcl_Alloc.  You might think we
 290      could just use the Tcl `pwd' command.  However, Tcl (erroneously,
 291      imho) maintains a cache of the current directory name, and
 292      doesn't provide a way for gdb to invalidate the cache.  */
 293   Tcl_LinkVar (interp, "gdb_current_directory",
 294                (char *) &current_directory,
 295                TCL_LINK_STRING | TCL_LINK_READ_ONLY);
 296
 297   /* Current gdb source file search path.  This is read-only for
 298      reasons similar to those for gdb_current_directory.  */
 299   Tcl_LinkVar (interp, "gdb_source_path",
 300                (char *) &source_path,
 301                TCL_LINK_STRING | TCL_LINK_READ_ONLY);
 302
 303   /* Init variable interface... */
 304   if (gdb_variable_init (interp) != TCL_OK)
 305     return TCL_ERROR;
 306
 307   /* Init breakpoint module */
 308   if (Gdbtk_Breakpoint_Init (interp) != TCL_OK)
 309     return TCL_ERROR;
 310
 311   /* Init stack module */
 312   if (Gdbtk_Stack_Init (interp) != TCL_OK)
 313     return TCL_ERROR;
 314
 315   /* Init register module */
 316   if (Gdbtk_Register_Init (interp) != TCL_OK)
 317     return TCL_ERROR;
 318
 319   /* Determine where to disassemble from */
 320   Tcl_LinkVar (gdbtk_interp, "disassemble-from-exec",
 321                (char *) &disassemble_from_exec,
 322                TCL_LINK_INT);
 323
 324   Tcl_PkgProvide (interp, "Gdbtk", GDBTK_VERSION);
 325   return TCL_OK;
 326 }
 327
 328 /* This routine acts as a top-level for all GDB code called by Tcl/Tk.  It
 329    handles cleanups, and uses catch_errors to trap calls to return_to_top_level
 330    (usually via error).
 331    This is necessary in order to prevent a longjmp out of the bowels of Tk,
 332    possibly leaving things in a bad state.  Since this routine can be called
 333    recursively, it needs to save and restore the contents of the result_ptr as
 334    necessary. */
 335
 336 int
 337 gdbtk_call_wrapper (ClientData clientData, Tcl_Interp *interp,
 338                     int objc, Tcl_Obj *CONST objv[])
 339 {
 340   struct wrapped_call_args wrapped_args;
 341   gdbtk_result new_result, *old_result_ptr;
 342   int wrapped_returned_error = 0;
 343
 344   old_result_ptr = result_ptr;
 345   result_ptr = &new_result;
 346   result_ptr->obj_ptr = Tcl_NewObj ();
 347   result_ptr->flags = GDBTK_TO_RESULT;
 348
 349   wrapped_args.func = (Tcl_ObjCmdProc *) clientData;
 350   wrapped_args.interp = interp;
 351   wrapped_args.objc = objc;
 352   wrapped_args.objv = objv;
 353   wrapped_args.val = TCL_OK;
 354
 355   if (!catch_errors (wrapped_call, &wrapped_args, "", RETURN_MASK_ALL))
 356     {
 357
 358       wrapped_args.val = TCL_ERROR;     /* Flag an error for TCL */
 359
 360       /* Make sure the timer interrupts are turned off.  */
 361       gdbtk_stop_timer ();
 362
 363       gdb_flush (gdb_stderr);   /* Flush error output */
 364       gdb_flush (gdb_stdout);   /* Sometimes error output comes here as well */
 365
 366       /* If we errored out here, and the results were going to the
 367          console, then gdbtk_fputs will have gathered the result into the
 368          result_ptr.  We also need to echo them out to the console here */
 369
 370       gdb_flush (gdb_stderr);   /* Flush error output */
 371       gdb_flush (gdb_stdout);   /* Sometimes error output comes here as well */
 372
 373       /* In case of an error, we may need to force the GUI into idle
 374          mode because gdbtk_call_command may have bombed out while in
 375          the command routine.  */
 376
 377       running_now = 0;
 378       Tcl_Eval (interp, "gdbtk_tcl_idle");
 379
 380     }
 381   else
 382     {
 383       /* If the wrapped call returned an error directly, then we don't
 384          want to reset the result.  */
 385       wrapped_returned_error = wrapped_args.val == TCL_ERROR;
 386     }
 387
 388   /* do not suppress any errors -- a remote target could have errored */
 389   load_in_progress = 0;
 390
 391   /*
 392    * Now copy the result over to the true Tcl result.  If
 393    * GDBTK_TO_RESULT flag bit is set, this just copies a null object
 394    * over to the Tcl result, which is fine because we should reset the
 395    * result in this case anyway.  If the wrapped command returned an
 396    * error, then we assume that the result is already set correctly.
 397    */
 398   if ((result_ptr->flags & GDBTK_IN_TCL_RESULT) || wrapped_returned_error)
 399     {
 400       Tcl_DecrRefCount (result_ptr->obj_ptr);
 401     }
 402   else
 403     {
 404       Tcl_SetObjResult (interp, result_ptr->obj_ptr);
 405     }
 406
 407   result_ptr = old_result_ptr;
 408
 409 #ifdef _WIN32
 410   close_bfds ();
 411 #endif
 412
 413   return wrapped_args.val;
 414 }
 415
 416 /*
 417  * This is the wrapper that is passed to catch_errors.
 418  */
 419
 420 static int
 421 wrapped_call (PTR opaque_args)
 422 {
 423   struct wrapped_call_args *args = (struct wrapped_call_args *) opaque_args;
 424   args->val = (*args->func) (args->func, args->interp, args->objc, args->objv);
 425   return 1;
 426 }
 427
 428 \f
 429 /*
 430  * This section contains the commands that control execution.
 431  */
 432
 433 /* This implements the tcl command gdb_clear_file.
 434
 435 * Prepare to accept a new executable file.  This is called when we
 436 * want to clear away everything we know about the old file, without
 437 * asking the user.  The Tcl code will have already asked the user if
 438 * necessary.  After this is called, we should be able to run the
 439 * `file' command without getting any questions.
 440 *
 441 * Arguments:
 442 *    None
 443 * Tcl Result:
 444 *    None
 445 */
 446
 447 static int
 448 gdb_clear_file (ClientData clientData, Tcl_Interp *interp,
 449                 int objc, Tcl_Obj *CONST objv[])
 450 {
 451   if (objc != 1)
 452     {
 453       Tcl_WrongNumArgs (interp, 1, objv, NULL);
 454       return TCL_ERROR;
 455     }
 456
 457   if (! ptid_equal (inferior_ptid, null_ptid) && target_has_execution)
 458     {
 459       if (attach_flag)
 460         target_detach (NULL, 0);
 461       else
 462         target_kill ();
 463     }
 464
 465   if (target_has_execution)
 466     pop_target ();
 467
 468   delete_command (NULL, 0);
 469   exec_file_clear (0);
 470   symbol_file_clear (0);
 471
 472   return TCL_OK;
 473 }
 474
 475 /* This implements the tcl command gdb_confirm_quit
 476  * Ask the user to confirm an exit request.
 477  *
 478  * Arguments:
 479  *    None
 480  * Tcl Result:
 481  *    A boolean, 1 if the user answered yes, 0 if no.
 482  */
 483
 484 static int
 485 gdb_confirm_quit (ClientData clientData, Tcl_Interp *interp,
 486                   int objc, Tcl_Obj *CONST objv[])
 487 {
 488   int ret;
 489
 490   if (objc != 1)
 491     {
 492       Tcl_WrongNumArgs (interp, 1, objv, NULL);
 493       return TCL_ERROR;
 494     }
 495
 496   ret = quit_confirm ();
 497   Tcl_SetBooleanObj (result_ptr->obj_ptr, ret);
 498   return TCL_OK;
 499 }
 500
 501 /* This implements the tcl command gdb_force_quit
 502  * Quit without asking for confirmation.
 503  *
 504  * Arguments:
 505  *    None
 506  * Tcl Result:
 507  *    None
 508  */
 509
 510 static int
 511 gdb_force_quit (ClientData clientData, Tcl_Interp *interp,
 512                 int objc, Tcl_Obj *CONST objv[])
 513 {
 514   if (objc != 1)
 515     {
 516       Tcl_WrongNumArgs (interp, 1, objv, NULL);
 517       return TCL_ERROR;
 518     }
 519
 520   quit_force ((char *) NULL, 1);
 521   return TCL_OK;
 522 }
 523
 524 /* Pressing the stop button on the source window should attempt to
 525  * stop the target. If, after some short time, this fails, a dialog
 526  * should appear allowing the user to detach.
 527  *
 528  * The global GDBTK_FORCE_DETACH is set when we wish to detach from a
 529  * target. This value is returned by deprecated_ui_loop_hook
 530  * (x_event), indicating to callers that they should detach.
 531  *
 532  * Read the comments before x_event to find out how we (try) to keep
 533  * gdbtk alive while some other event loop has stolen control from us.
 534  */
 535
 536 /*
 537  * This command implements the tcl command gdb_stop, which
 538  * is used to either stop the target or detach.
 539  * Note that it is assumed that a simulator or native target
 540  * can ALWAYS be stopped. Doing a "detach" on them has no effect.
 541  *
 542  * Arguments:
 543  *    None or "detach"
 544  * Tcl Result:
 545  *    None
 546  */
 547
 548 static int
 549 gdb_stop (ClientData clientData, Tcl_Interp *interp,
 550           int objc, Tcl_Obj *CONST objv[])
 551 {
 552   int force = 0;
 553   char *s;
 554
 555   if (objc > 1)
 556     {
 557       s = Tcl_GetStringFromObj (objv[1], NULL);
 558       if (strcmp (s, "detach") == 0)
 559         force = 1;
 560     }
 561
 562   if (force)
 563     {
 564       /* Set the "forcibly detach from target" flag. x_event will
 565          return this value to callers when they should forcibly detach. */
 566       gdbtk_force_detach = 1;
 567     }
 568   else
 569     {
 570       if (target_ignore != (void (*) (void)) current_target.to_stop)
 571         target_stop (gdbtk_get_ptid ());
 572       else
 573         quit_flag = 1;          /* hope something sees this */
 574     }
 575
 576   return TCL_OK;
 577 }
 578 \f
 579
 580 /*
 581  * This section contains Tcl commands that are wrappers for invoking
 582  * the GDB command interpreter.
 583  */
 584
 585
 586 /* This implements the tcl command `gdb_eval'.
 587  * It uses the gdb evaluator to return the value of
 588  * an expression in the current language
 589  *
 590  * Tcl Arguments:
 591  *     expression - the expression to evaluate.
 592  *     format - optional format character.  Valid chars are:
 593  *      o - octal
 594  *      x - hex
 595  *      d - decimal
 596  *      u - unsigned decimal
 597  *      t - binary
 598  *      f - float
 599  *      a - address
 600  *      c - char
 601  * Tcl Result:
 602  *     The result of the evaluation.
 603  */
 604
 605 static int
 606 gdb_eval (ClientData clientData, Tcl_Interp *interp,
 607           int objc, Tcl_Obj *CONST objv[])
 608 {
 609   struct expression *expr;
 610   struct cleanup *old_chain = NULL;
 611   int format = 0;
 612   value_ptr val;
 613   struct ui_file *stb;
 614   long dummy;
 615   char *result;
 616
 617   if (objc != 2 && objc != 3)
 618     {
 619       Tcl_WrongNumArgs (interp, 1, objv, "expression [format]");
 620       return TCL_ERROR;
 621     }
 622
 623   if (objc == 3)
 624     format = *(Tcl_GetStringFromObj (objv[2], NULL));
 625
 626   expr = parse_expression (Tcl_GetStringFromObj (objv[1], NULL));
 627   old_chain = make_cleanup (free_current_contents, &expr);
 628   val = evaluate_expression (expr);
 629
 630   /* "Print" the result of the expression evaluation. */
 631   stb = mem_fileopen ();
 632   make_cleanup_ui_file_delete (stb);
 633   val_print (value_type (val), value_contents (val),
 634              value_embedded_offset (val), VALUE_ADDRESS (val),
 635              stb, format, 0, 0, 0, current_language);
 636   result = ui_file_xstrdup (stb, &dummy);
 637   Tcl_SetObjResult (interp, Tcl_NewStringObj (result, -1));
 638   xfree (result);
 639   result_ptr->flags |= GDBTK_IN_TCL_RESULT;
 640
 641   do_cleanups (old_chain);
 642   return TCL_OK;
 643 }
 644
 645 /* This implements the tcl command "gdb_cmd".
 646
 647 * It sends its argument to the GDB command scanner for execution.
 648 * This command will never cause the update, idle and busy hooks to be called
 649 * within the GUI.
 650 *
 651 * Tcl Arguments:
 652 *    command - The GDB command to execute
 653 *    from_tty - 1 indicates this comes to the console.
 654 *               Pass this to the gdb command.
 655 * Tcl Result:
 656 *    The output from the gdb command (except for the "load" & "while"
 657 *    which dump their output to the console.
 658 */
 659
 660 static int
 661 gdb_cmd (ClientData clientData, Tcl_Interp *interp,
 662          int objc, Tcl_Obj *CONST objv[])
 663 {
 664   int from_tty = 0;
 665
 666   if (objc < 2 || objc > 3)
 667     {
 668       Tcl_WrongNumArgs (interp, 1, objv, "command ?from_tty?");
 669       return TCL_ERROR;
 670     }
 671
 672   if (objc == 3)
 673     {
 674       if (Tcl_GetBooleanFromObj (NULL, objv[2], &from_tty) != TCL_OK)
 675         {
 676           gdbtk_set_result (interp, "from_tty must be a boolean.");
 677           return TCL_ERROR;
 678         }
 679     }
 680
 681   if (running_now || load_in_progress)
 682     return TCL_OK;
 683
 684   No_Update = 1;
 685
 686   /* for the load instruction (and possibly others later) we
 687      set turn off the GDBTK_TO_RESULT flag bit so gdbtk_fputs()
 688      will not buffer all the data until the command is finished. */
 689
 690   if ((strncmp ("load ", Tcl_GetStringFromObj (objv[1], NULL), 5) == 0))
 691     {
 692       result_ptr->flags &= ~GDBTK_TO_RESULT;
 693       load_in_progress = 1;
 694     }
 695
 696   execute_command (Tcl_GetStringFromObj (objv[1], NULL), from_tty);
 697
 698   if (load_in_progress)
 699     {
 700       load_in_progress = 0;
 701       result_ptr->flags |= GDBTK_TO_RESULT;
 702     }
 703
 704   bpstat_do_actions (&stop_bpstat);
 705
 706   return TCL_OK;
 707 }
 708
 709 /*
 710  * This implements the tcl command "gdb_immediate"
 711  *
 712  * It does exactly the same thing as gdb_cmd, except NONE of its outut
 713  * is buffered.  This will also ALWAYS cause the busy, update, and idle
 714  * hooks to be called, contrasted with gdb_cmd, which NEVER calls them.
 715  * It turns off the GDBTK_TO_RESULT flag, which diverts the result
 716  * to the console window.
 717  *
 718  * Tcl Arguments:
 719  *    command - The GDB command to execute
 720  *    from_tty - 1 to indicate this is from the console.
 721  * Tcl Result:
 722  *    None.
 723  */
 724
 725 static int
 726 gdb_immediate_command (ClientData clientData, Tcl_Interp *interp,
 727                        int objc, Tcl_Obj *CONST objv[])
 728 {
 729   int from_tty = 0;
 730
 731   if (objc < 2 || objc > 3)
 732     {
 733       Tcl_WrongNumArgs (interp, 1, objv, "command ?from_tty?");
 734       return TCL_ERROR;
 735     }
 736
 737   if (objc == 3)
 738     {
 739       if (Tcl_GetBooleanFromObj (NULL, objv[2], &from_tty) != TCL_OK)
 740         {
 741           gdbtk_set_result (interp, "from_tty must be a boolean.");
 742           return TCL_ERROR;
 743         }
 744     }
 745
 746   if (running_now || load_in_progress)
 747     return TCL_OK;
 748
 749   No_Update = 0;
 750
 751   result_ptr->flags &= ~GDBTK_TO_RESULT;
 752
 753   execute_command (Tcl_GetStringFromObj (objv[1], NULL), from_tty);
 754
 755   bpstat_do_actions (&stop_bpstat);
 756
 757   result_ptr->flags |= GDBTK_TO_RESULT;
 758
 759   return TCL_OK;
 760 }
 761
 762 /* This implements the tcl command "gdb_prompt"
 763
 764 * It returns the gdb interpreter's prompt.
 765 *
 766 * Tcl Arguments:
 767 *    None.
 768 * Tcl Result:
 769 *    The prompt.
 770 */
 771
 772 static int
 773 gdb_prompt_command (ClientData clientData, Tcl_Interp *interp,
 774                     int objc, Tcl_Obj *CONST objv[])
 775 {
 776   Tcl_SetStringObj (result_ptr->obj_ptr, get_prompt (), -1);
 777   return TCL_OK;
 778 }
 779 \f
 780
 781 /*
 782  * This section contains general informational commands.
 783  */
 784
 785 /* This implements the tcl command "gdb_target_has_execution"
 786
 787 * Tells whether the target is executing.
 788 *
 789 * Tcl Arguments:
 790 *    None
 791 * Tcl Result:
 792 *    A boolean indicating whether the target is executing.
 793 */
 794
 795 static int
 796 gdb_target_has_execution_command (ClientData clientData, Tcl_Interp *interp,
 797                                   int objc, Tcl_Obj *CONST objv[])
 798 {
 799   int result = 0;
 800
 801   if (target_has_execution && ! ptid_equal (inferior_ptid, null_ptid))
 802     result = 1;
 803
 804   Tcl_SetBooleanObj (result_ptr->obj_ptr, result);
 805   return TCL_OK;
 806 }
 807
 808 /* This implements the tcl command "gdb_get_inferior_args"
 809
 810 * Returns inferior command line arguments as a string
 811 *
 812 * Tcl Arguments:
 813 *    None
 814 * Tcl Result:
 815 *    A string containing the inferior command line arguments
 816 */
 817
 818 static int
 819 gdb_get_inferior_args (ClientData clientData, Tcl_Interp *interp,
 820                        int objc, Tcl_Obj *CONST objv[])
 821 {
 822   if (objc != 1)
 823     {
 824       Tcl_WrongNumArgs (interp, 1, objv, NULL);
 825       return TCL_ERROR;
 826     }
 827
 828   Tcl_SetStringObj (result_ptr->obj_ptr, get_inferior_args (), -1);
 829   return TCL_OK;
 830 }
 831
 832 /* This implements the tcl command "gdb_set_inferior_args"
 833
 834 * Sets inferior command line arguments
 835 *
 836 * Tcl Arguments:
 837 *    A string containing the inferior command line arguments
 838 * Tcl Result:
 839 *    None
 840 */
 841
 842 static int
 843 gdb_set_inferior_args (ClientData clientData, Tcl_Interp *interp,
 844                        int objc, Tcl_Obj *CONST objv[])
 845 {
 846   char *args;
 847
 848   if (objc != 2)
 849     {
 850       Tcl_WrongNumArgs (interp, 1, objv, "argument");
 851       return TCL_ERROR;
 852     }
 853
 854   args = Tcl_GetStringFromObj (objv[1], NULL);
 855
 856   /* The xstrdup/xfree stuff is so that we maintain a coherent picture
 857      for gdb.  I would expect the accessors to do this, but they
 858      don't.  */
 859   args = xstrdup (args);
 860   args = set_inferior_args (args);
 861   xfree (args);
 862
 863   return TCL_OK;
 864 }
 865
 866 /* This implements the tcl command "gdb_load_info"
 867
 868 * It returns information about the file about to be downloaded.
 869 *
 870 * Tcl Arguments:
 871 *    filename: The file to open & get the info on.
 872 * Tcl Result:
 873 *    A list consisting of the name and size of each section.
 874 */
 875
 876 static int
 877 gdb_load_info (ClientData clientData, Tcl_Interp *interp,
 878                int objc, Tcl_Obj *CONST objv[])
 879 {
 880   bfd *loadfile_bfd;
 881   struct cleanup *old_cleanups;
 882   asection *s;
 883   Tcl_Obj *ob[2];
 884
 885   char *filename = Tcl_GetStringFromObj (objv[1], NULL);
 886
 887   loadfile_bfd = bfd_openr (filename, gnutarget);
 888   if (loadfile_bfd == NULL)
 889     {
 890       gdbtk_set_result (interp, "Open of %s failed", filename);
 891       return TCL_ERROR;
 892     }
 893   old_cleanups = make_cleanup_bfd_close (loadfile_bfd);
 894
 895   if (!bfd_check_format (loadfile_bfd, bfd_object))
 896     {
 897       gdbtk_set_result (interp, "Bad Object File");
 898       return TCL_ERROR;
 899     }
 900
 901   Tcl_SetListObj (result_ptr->obj_ptr, 0, NULL);
 902
 903   for (s = loadfile_bfd->sections; s; s = s->next)
 904     {
 905       if (s->flags & SEC_LOAD)
 906         {
 907           bfd_size_type size = bfd_get_section_size (s);
 908           if (size > 0)
 909             {
 910               ob[0] = Tcl_NewStringObj ((char *)
 911                                         bfd_get_section_name (loadfile_bfd, s),
 912                                         -1);
 913               ob[1] = Tcl_NewLongObj ((long) size);
 914               Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
 915                                         Tcl_NewListObj (2, ob));
 916             }
 917         }
 918     }
 919
 920   do_cleanups (old_cleanups);
 921   return TCL_OK;
 922 }
 923
 924
 925 /* This implements the tcl command "gdb_get_line"
 926
 927 * It returns the linenumber for a given linespec.  It will take any spec
 928 * that can be passed to decode_line_1
 929 *
 930 * Tcl Arguments:
 931 *    linespec - the line specification
 932 * Tcl Result:
 933 *    The line number for that spec.
 934 */
 935 static int
 936 gdb_get_line_command (ClientData clientData, Tcl_Interp *interp,
 937                       int objc, Tcl_Obj *CONST objv[])
 938 {
 939   struct symtabs_and_lines sals;
 940   char *args, **canonical;
 941
 942   if (objc != 2)
 943     {
 944       Tcl_WrongNumArgs (interp, 1, objv, "linespec");
 945       return TCL_ERROR;
 946     }
 947
 948   args = Tcl_GetStringFromObj (objv[1], NULL);
 949   sals = decode_line_1 (&args, 1, NULL, 0, &canonical, NULL);
 950   if (sals.nelts == 1)
 951     {
 952       Tcl_SetIntObj (result_ptr->obj_ptr, sals.sals[0].line);
 953       return TCL_OK;
 954     }
 955
 956   Tcl_SetStringObj (result_ptr->obj_ptr, "N/A", -1);
 957   return TCL_OK;
 958
 959 }
 960
 961 /* This implements the tcl command "gdb_get_file"
 962
 963 * It returns the file containing a given line spec.
 964 *
 965 * Tcl Arguments:
 966 *    linespec - The linespec to look up
 967 * Tcl Result:
 968 *    The file containing it.
 969 */
 970
 971 static int
 972 gdb_get_file_command (ClientData clientData, Tcl_Interp *interp,
 973                       int objc, Tcl_Obj *CONST objv[])
 974 {
 975   struct symtabs_and_lines sals;
 976   char *args, **canonical;
 977
 978   if (objc != 2)
 979     {
 980       Tcl_WrongNumArgs (interp, 1, objv, "linespec");
 981       return TCL_ERROR;
 982     }
 983
 984   args = Tcl_GetStringFromObj (objv[1], NULL);
 985   sals = decode_line_1 (&args, 1, NULL, 0, &canonical, NULL);
 986   if (sals.nelts == 1)
 987     {
 988       Tcl_SetStringObj (result_ptr->obj_ptr,
 989                         sals.sals[0].symtab->filename, -1);
 990       return TCL_OK;
 991     }
 992
 993   Tcl_SetStringObj (result_ptr->obj_ptr, "N/A", -1);
 994   return TCL_OK;
 995 }
 996
 997 /* This implements the tcl command "gdb_get_function"
 998
 999 * It finds the function containing the given line spec.
1000 *
1001 * Tcl Arguments:
1002 *    linespec - The line specification
1003 * Tcl Result:
1004 *    The function that contains it, or "N/A" if it is not in a function.
1005 */
1006 static int
1007 gdb_get_function_command (ClientData clientData, Tcl_Interp *interp,
1008                           int objc, Tcl_Obj *CONST objv[])
1009 {
1010   char *function;
1011   struct symtabs_and_lines sals;
1012   char *args, **canonical;
1013
1014   if (objc != 2)
1015     {
1016       Tcl_WrongNumArgs (interp, 1, objv, "linespec");
1017       return TCL_ERROR;
1018     }
1019
1020   args = Tcl_GetStringFromObj (objv[1], NULL);
1021   sals = decode_line_1 (&args, 1, NULL, 0, &canonical, NULL);
1022   if (sals.nelts == 1)
1023     {
1024       resolve_sal_pc (&sals.sals[0]);
1025       function = pc_function_name (sals.sals[0].pc);
1026       Tcl_SetStringObj (result_ptr->obj_ptr, function, -1);
1027       return TCL_OK;
1028     }
1029
1030   Tcl_SetStringObj (result_ptr->obj_ptr, "N/A", -1);
1031   return TCL_OK;
1032 }
1033
1034 /* This implements the tcl command "gdb_find_file"
1035
1036 * It searches the symbol tables to get the full pathname to a file.
1037 *
1038 * Tcl Arguments:
1039 *    filename: the file name to search for.
1040 * Tcl Result:
1041 *    The full path to the file, an empty string if the file was not
1042 *    available or an error message if the file is not found in the symtab.
1043 */
1044
1045 static int
1046 gdb_find_file_command (ClientData clientData, Tcl_Interp *interp,
1047                        int objc, Tcl_Obj *CONST objv[])
1048 {
1049   struct symtab *st;
1050   char *filename, *fullname = NULL;
1051
1052   if (objc != 2)
1053     {
1054       Tcl_WrongNumArgs (interp, 1, objv, "filename");
1055       return TCL_ERROR;
1056     }
1057
1058   filename = Tcl_GetStringFromObj (objv[1], NULL);
1059
1060   /* Shortcut: There seems to be some mess in gdb dealing with
1061      files. While we should let gdb sort it out, it doesn't hurt
1062      to be a little defensive here.
1063
1064      If the filename is already an absolute filename, just try
1065      to stat it. If it's not found, then ask gdb to find it for us. */
1066   if (IS_ABSOLUTE_PATH (filename))
1067     {
1068       struct stat st;
1069       const int status = stat (filename, &st);
1070
1071       if (status == 0)
1072         {
1073           if (S_ISREG (st.st_mode))
1074             fullname = filename;
1075         }
1076     }
1077   else
1078     {
1079       /* Ask gdb to find the file for us. */
1080       st = lookup_symtab (filename);
1081
1082       /* We should always get a symtab. */
1083       if (!st)
1084         {
1085           gdbtk_set_result (interp, "File not found in symtab (2)");
1086           return TCL_ERROR;
1087         }
1088
1089       fullname =
1090         (st->fullname == NULL ? symtab_to_filename (st) : st->fullname);
1091     }
1092
1093   /* We may not be able to open the file (not available). */
1094   if (fullname == NULL)
1095     {
1096       Tcl_SetStringObj (result_ptr->obj_ptr, "", -1);
1097       return TCL_OK;
1098     }
1099
1100   Tcl_SetStringObj (result_ptr->obj_ptr, fullname, -1);
1101
1102   return TCL_OK;
1103 }
1104
1105 /* This implements the tcl command "gdb_listfiles"
1106
1107 * This lists all the files in the current executible.
1108 *
1109 * Note that this currently pulls in all sorts of filenames
1110 * that aren't really part of the executable.  It would be
1111 * best if we could check each file to see if it actually
1112 * contains executable lines of code, but we can't do that
1113 * with psymtabs.
1114 *
1115 * Arguments:
1116 *    ?pathname? - If provided, only files which match pathname
1117 *        (up to strlen(pathname)) are included. THIS DOES NOT
1118 *        CURRENTLY WORK BECAUSE PARTIAL_SYMTABS DON'T SUPPLY
1119 *        THE FULL PATHNAME!!!
1120 *
1121 * Tcl Result:
1122 *    A list of all matching files.
1123 */
1124 static int
1125 gdb_listfiles (ClientData clientData, Tcl_Interp *interp,
1126                int objc, Tcl_Obj *CONST objv[])
1127 {
1128   struct objfile *objfile;
1129   struct partial_symtab *psymtab;
1130   struct symtab *symtab;
1131   const char *lastfile, *pathname = NULL;
1132   const char **files;
1133   int files_size;
1134   int i, numfiles = 0, len = 0;
1135
1136   files_size = 1000;
1137   files = (const char **) xmalloc (sizeof (char *) * files_size);
1138
1139   if (objc > 2)
1140     {
1141       Tcl_WrongNumArgs (interp, 1, objv, "?pathname?");
1142       return TCL_ERROR;
1143     }
1144   else if (objc == 2)
1145     pathname = Tcl_GetStringFromObj (objv[1], &len);
1146
1147   ALL_PSYMTABS (objfile, psymtab)
1148     {
1149       if (numfiles == files_size)
1150         {
1151           files_size = files_size * 2;
1152           files = (const char **) xrealloc (files, sizeof (char *) * files_size);
1153         }
1154       if (psymtab->filename)
1155         {
1156           if (!len || !strncmp (pathname, psymtab->filename, len)
1157               || !strcmp (psymtab->filename, lbasename (psymtab->filename)))
1158             {
1159               files[numfiles++] = lbasename (psymtab->filename);
1160             }
1161         }
1162     }
1163
1164   ALL_SYMTABS (objfile, symtab)
1165     {
1166       if (numfiles == files_size)
1167         {
1168           files_size = files_size * 2;
1169           files = (const char **) xrealloc (files, sizeof (char *) * files_size);
1170         }
1171       if (symtab->filename && symtab->linetable && symtab->linetable->nitems)
1172         {
1173           if (!len || !strncmp (pathname, symtab->filename, len)
1174               || !strcmp (symtab->filename, lbasename (symtab->filename)))
1175             {
1176               files[numfiles++] = lbasename (symtab->filename);
1177             }
1178         }
1179     }
1180
1181   qsort (files, numfiles, sizeof (char *), comp_files);
1182
1183   lastfile = "";
1184
1185   /* Discard the old result pointer, in case it has accumulated anything
1186      and set it to a new list object */
1187
1188   Tcl_SetListObj (result_ptr->obj_ptr, 0, NULL);
1189
1190   for (i = 0; i < numfiles; i++)
1191     {
1192       if (strcmp (files[i], lastfile))
1193         Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr,
1194                                   Tcl_NewStringObj (files[i], -1));
1195       lastfile = files[i];
1196     }
1197
1198   free (files);
1199   return TCL_OK;
1200 }
1201
1202 static int
1203 comp_files (const void *file1, const void *file2)
1204 {
1205   return strcmp (*(char **) file1, *(char **) file2);
1206 }
1207
1208
1209 /* This implements the tcl command "gdb_search"
1210
1211
1212 * Tcl Arguments:
1213 *    option - One of "functions", "variables" or "types"
1214 *    regexp - The regular expression to look for.
1215 * Then, optionally:
1216 *    -files fileList
1217 *    -static 1/0
1218 *    -filename 1/0
1219 * Tcl Result:
1220 *    A list of all the matches found.  Optionally, if -filename is set to 1,
1221 *    then the output is a list of two element lists, with the symbol first,
1222 *    and the file in which it is found second.
1223 */
1224
1225 static int
1226 gdb_search (ClientData clientData, Tcl_Interp *interp,
1227             int objc, Tcl_Obj *CONST objv[])
1228 {
1229   struct symbol_search *ss = NULL;
1230   struct symbol_search *p;
1231   struct cleanup *old_chain = NULL;
1232   Tcl_Obj *CONST * switch_objv;
1233   int index, switch_objc, i, show_files = 0;
1234   domain_enum space = 0;
1235   char *regexp;
1236   int static_only, nfiles;
1237   Tcl_Obj **file_list;
1238   char **files;
1239   static const char *search_options[] =
1240     {"functions", "variables", "types", (char *) NULL};
1241   static const char *switches[] =
1242     {"-files", "-filename", "-static", (char *) NULL};
1243   enum search_opts
1244     {
1245       SEARCH_FUNCTIONS, SEARCH_VARIABLES, SEARCH_TYPES
1246     };
1247   enum switches_opts
1248     {
1249       SWITCH_FILES, SWITCH_FILENAME, SWITCH_STATIC_ONLY
1250     };
1251
1252   if (objc < 3)
1253     {
1254       Tcl_WrongNumArgs (interp, 1, objv, "option regexp ?arg ...?");
1255       return TCL_ERROR;
1256     }
1257
1258   if (Tcl_GetIndexFromObj (interp, objv[1], search_options, "option", 0,
1259                            &index) != TCL_OK)
1260     {
1261       result_ptr->flags |= GDBTK_IN_TCL_RESULT;
1262       return TCL_ERROR;
1263     }
1264
1265   /* Unfortunately, we cannot teach search_symbols to search on
1266      multiple regexps, so we have to do a two-tier search for
1267      any searches which choose to narrow the playing field. */
1268   switch ((enum search_opts) index)
1269     {
1270     case SEARCH_FUNCTIONS:
1271       space = FUNCTIONS_DOMAIN;
1272       break;
1273     case SEARCH_VARIABLES:
1274       space = VARIABLES_DOMAIN;
1275       break;
1276     case SEARCH_TYPES:
1277       space = TYPES_DOMAIN;
1278       break;
1279     }
1280
1281   regexp = Tcl_GetStringFromObj (objv[2], NULL);
1282   /* Process any switches that refine the search */
1283   switch_objc = objc - 3;
1284   switch_objv = objv + 3;
1285
1286   static_only = 0;
1287   nfiles = 0;
1288   files = (char **) NULL;
1289   while (switch_objc > 0)
1290     {
1291       if (Tcl_GetIndexFromObj (interp, switch_objv[0], switches,
1292                                "option", 0, &index) != TCL_OK)
1293         {
1294           result_ptr->flags |= GDBTK_IN_TCL_RESULT;
1295           return TCL_ERROR;
1296         }
1297
1298       switch ((enum switches_opts) index)
1299         {
1300         case SWITCH_FILENAME:
1301           {
1302             if (switch_objc < 2)
1303               {
1304                 Tcl_WrongNumArgs (interp, 3, objv,
1305                                   "?-files fileList  -filename 1|0 -static 1|0?");
1306                 result_ptr->flags |= GDBTK_IN_TCL_RESULT;
1307                 return TCL_ERROR;
1308               }
1309             if (Tcl_GetBooleanFromObj (interp, switch_objv[1], &show_files)
1310                 != TCL_OK)
1311               {
1312                 result_ptr->flags |= GDBTK_IN_TCL_RESULT;
1313                 return TCL_ERROR;
1314               }
1315             switch_objc--;
1316             switch_objv++;
1317           }
1318           break;
1319         case SWITCH_FILES:
1320           {
1321             int result;
1322             if (switch_objc < 2)
1323               {
1324                 Tcl_WrongNumArgs (interp, 3, objv,
1325                                   "?-files fileList  -filename 1|0 -static 1|0?");
1326                 result_ptr->flags |= GDBTK_IN_TCL_RESULT;
1327                 return TCL_ERROR;
1328               }
1329             result = Tcl_ListObjGetElements (interp, switch_objv[1],
1330                                              &nfiles, &file_list);
1331             if (result != TCL_OK)
1332               return result;
1333
1334             files = (char **) xmalloc (nfiles * sizeof (char *));
1335             for (i = 0; i < nfiles; i++)
1336               files[i] = Tcl_GetStringFromObj (file_list[i], NULL);
1337             switch_objc--;
1338             switch_objv++;
1339           }
1340           break;
1341         case SWITCH_STATIC_ONLY:
1342           if (switch_objc < 2)
1343             {
1344               Tcl_WrongNumArgs (interp, 3, objv,
1345                                 "?-files fileList  -filename 1|0 -static 1|0?");
1346               result_ptr->flags |= GDBTK_IN_TCL_RESULT;
1347               return TCL_ERROR;
1348             }
1349           if (Tcl_GetBooleanFromObj (interp, switch_objv[1], &static_only)
1350               != TCL_OK)
1351             {
1352               result_ptr->flags |= GDBTK_IN_TCL_RESULT;
1353               return TCL_ERROR;
1354             }
1355           switch_objc--;
1356           switch_objv++;
1357         }
1358       switch_objc--;
1359       switch_objv++;
1360     }
1361
1362   search_symbols (regexp, space, nfiles, files, &ss);
1363   if (ss != NULL)
1364     old_chain = make_cleanup_free_search_symbols (ss);
1365
1366   Tcl_SetListObj (result_ptr->obj_ptr, 0, NULL);
1367
1368   for (p = ss; p != NULL; p = p->next)
1369     {
1370       Tcl_Obj *elem;
1371
1372       if (static_only && p->block != STATIC_BLOCK)
1373         continue;
1374
1375       /* Strip off some C++ special symbols, like RTTI and global
1376          constructors/destructors. */
1377       if ((p->symbol != NULL
1378            && strncmp (SYMBOL_LINKAGE_NAME (p->symbol), "__tf", 4) != 0
1379            && strncmp (SYMBOL_LINKAGE_NAME (p->symbol), "_GLOBAL_", 8) != 0)
1380           || p->msymbol != NULL)
1381         {
1382           elem = Tcl_NewListObj (0, NULL);
1383
1384           if (p->msymbol == NULL)
1385             Tcl_ListObjAppendElement (interp, elem,
1386                                       Tcl_NewStringObj (SYMBOL_PRINT_NAME (p->symbol), -1));
1387           else
1388             Tcl_ListObjAppendElement (interp, elem,
1389                                       Tcl_NewStringObj (SYMBOL_PRINT_NAME (p->msymbol), -1));
1390
1391           if (show_files)
1392             {
1393               if ((p->symtab != NULL) && (p->symtab->filename != NULL))
1394                 {
1395                   Tcl_ListObjAppendElement (interp, elem, Tcl_NewStringObj
1396                                             (p->symtab->filename, -1));
1397                 }
1398               else
1399                 {
1400                   Tcl_ListObjAppendElement (interp, elem,
1401                                             Tcl_NewStringObj ("", 0));
1402                 }
1403             }
1404
1405           Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr, elem);
1406         }
1407     }
1408
1409   if (ss != NULL)
1410     do_cleanups (old_chain);
1411
1412   return TCL_OK;
1413 }
1414
1415 /* This implements the tcl command gdb_listfuncs
1416
1417 * It lists all the functions defined in a given file
1418 *
1419 * Arguments:
1420 *    file - the file to look in
1421 * Tcl Result:
1422 *    A list of two element lists, the first element is
1423 *    the symbol name, and the second is a boolean indicating
1424 *    whether the symbol is demangled (1 for yes).
1425 */
1426
1427 static int
1428 gdb_listfuncs (clientData, interp, objc, objv)
1429      ClientData clientData;
1430      Tcl_Interp *interp;
1431      int objc;
1432      Tcl_Obj *CONST objv[];
1433 {
1434   struct symtab *symtab;
1435   struct blockvector *bv;
1436   struct block *b;
1437   struct symbol *sym;
1438   int i;
1439   struct dict_iterator iter;
1440   Tcl_Obj *funcVals[2];
1441
1442   if (objc != 2)
1443     {
1444       Tcl_WrongNumArgs (interp, 1, objv, "file");
1445       return TCL_ERROR;
1446     }
1447
1448   symtab = lookup_symtab (Tcl_GetStringFromObj (objv[1], NULL));
1449   if (!symtab)
1450     {
1451       gdbtk_set_result (interp, "No such file (%s)",
1452                         Tcl_GetStringFromObj (objv[1], NULL));
1453       return TCL_ERROR;
1454     }
1455
1456   if (mangled == NULL)
1457     {
1458       mangled = Tcl_NewBooleanObj (1);
1459       not_mangled = Tcl_NewBooleanObj (0);
1460       Tcl_IncrRefCount (mangled);
1461       Tcl_IncrRefCount (not_mangled);
1462     }
1463
1464   Tcl_SetListObj (result_ptr->obj_ptr, 0, NULL);
1465
1466   bv = BLOCKVECTOR (symtab);
1467   for (i = GLOBAL_BLOCK; i <= STATIC_BLOCK; i++)
1468     {
1469       b = BLOCKVECTOR_BLOCK (bv, i);
1470       ALL_BLOCK_SYMBOLS (b, iter, sym)
1471         {
1472           if (SYMBOL_CLASS (sym) == LOC_BLOCK)
1473             {
1474
1475               char *name = SYMBOL_DEMANGLED_NAME (sym);
1476
1477               if (name)
1478                 {
1479                   /* strip out "global constructors" and
1480                    * "global destructors"
1481                    * because we aren't interested in them. */
1482
1483                   if (strncmp (name, "global ", 7))
1484                     {
1485                       /* If the function is overloaded,
1486                        * print out the functions
1487                        * declaration, not just its name. */
1488
1489                       funcVals[0] = Tcl_NewStringObj (name, -1);
1490                       funcVals[1] = mangled;
1491                     }
1492                   else
1493                     continue;
1494
1495                 }
1496               else
1497                 {
1498                   funcVals[0] = Tcl_NewStringObj (DEPRECATED_SYMBOL_NAME (sym), -1);
1499                   funcVals[1] = not_mangled;
1500                 }
1501               Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
1502                                         Tcl_NewListObj (2, funcVals));
1503             }
1504         }
1505     }
1506   return TCL_OK;
1507 }
1508 \f
1509 /* This implements the TCL command `gdb_restore_fputs'
1510    It sets the fputs_unfiltered hook back to gdbtk_fputs.
1511    Its sole reason for being is that sometimes we move the
1512    fputs hook out of the way to specially trap output, and if
1513    we get an error which we weren't expecting, it won't get put
1514    back, so we run this at idle time as insurance.
1515 */
1516
1517 static int
1518 gdb_restore_fputs (ClientData clientData, Tcl_Interp *interp,
1519                    int objc, Tcl_Obj *CONST objv[])
1520 {
1521   gdbtk_disable_fputs = 0;
1522   return TCL_OK;
1523 }
1524 \f
1525
1526 /* This implements the tcl command gdb_load_disassembly
1527  *
1528  * Arguments:
1529  *    widget - the name of a text widget into which to load the data
1530  *    source_with_assm - must be "source" or "nosource"
1531  *    low_address - the CORE_ADDR from which to start disassembly
1532  *    ?hi_address? - the CORE_ADDR to which to disassemble, defaults
1533  *                   to the end of the function containing low_address.
1534  * Tcl Result:
1535  *    The text widget is loaded with the data, and a list is returned.
1536  *    The first element of the list is a two element list containing the
1537  *    real low & high elements, the rest is a mapping between line number
1538  *    in the text widget, and either the source line number of that line,
1539  *    if it is a source line, or the assembly address.  You can distinguish
1540  *    between the two, because the address will start with 0x...
1541  */
1542
1543 static int
1544 gdb_load_disassembly (ClientData clientData, Tcl_Interp *interp,
1545                       int objc, Tcl_Obj *CONST objv[])
1546 {
1547   CORE_ADDR low, high, orig;
1548   struct disassembly_client_data client_data;
1549   int mixed_source_and_assembly, ret_val, i;
1550   char *arg_ptr;
1551   char *map_name;
1552   Tcl_WideInt waddr;
1553
1554   if (objc != 6 && objc != 7)
1555     {
1556       Tcl_WrongNumArgs (interp, 1, objv, "[source|nosource] map_arr index_prefix low_address ?hi_address");
1557       return TCL_ERROR;
1558     }
1559
1560   client_data.widget = Tcl_GetStringFromObj (objv[1], NULL);
1561   if ( Tk_NameToWindow (interp, client_data.widget,
1562                         Tk_MainWindow (interp)) == NULL)
1563     {
1564       gdbtk_set_result (interp, "Invalid widget name.");
1565       return TCL_ERROR;
1566     }
1567
1568   if (!Tcl_GetCommandInfo (interp, client_data.widget, &client_data.cmd))
1569     {
1570       gdbtk_set_result (interp, "Can't get widget command info");
1571       return TCL_ERROR;
1572     }
1573
1574   arg_ptr = Tcl_GetStringFromObj (objv[2], NULL);
1575   if (*arg_ptr == 's' && strcmp (arg_ptr, "source") == 0)
1576     mixed_source_and_assembly = 1;
1577   else if (*arg_ptr == 'n' && strcmp (arg_ptr, "nosource") == 0)
1578     mixed_source_and_assembly = 0;
1579   else
1580     {
1581       gdbtk_set_result (interp, "Second arg must be 'source' or 'nosource'");
1582       return TCL_ERROR;
1583     }
1584
1585   /* As we populate the text widget, we will also create an array in the
1586      caller's scope.  The name is given by objv[3].
1587      Each source line gets an entry or the form:
1588      array($prefix,srcline=$src_line_no) = $widget_line_no
1589
1590      Each assembly line gets two entries of the form:
1591      array($prefix,pc=$pc) = $widget_line_no
1592      array($prefix,line=$widget_line_no) = $src_line_no
1593
1594      Where prefix is objv[4].
1595   */
1596
1597   map_name = Tcl_GetStringFromObj (objv[3], NULL);
1598
1599   if (*map_name != '\0')
1600     {
1601       char *prefix;
1602       int prefix_len;
1603
1604       client_data.map_arr = "map_array";
1605       if (Tcl_UpVar (interp, "1", map_name, client_data.map_arr, 0) != TCL_OK)
1606         {
1607           gdbtk_set_result (interp, "Can't link map array.");
1608           return TCL_ERROR;
1609         }
1610
1611       prefix = Tcl_GetStringFromObj (objv[4], &prefix_len);
1612
1613       Tcl_DStringInit(&client_data.src_to_line_prefix);
1614       Tcl_DStringAppend (&client_data.src_to_line_prefix,
1615                          prefix, prefix_len);
1616       Tcl_DStringAppend (&client_data.src_to_line_prefix, ",srcline=",
1617                          sizeof (",srcline=") - 1);
1618
1619       Tcl_DStringInit(&client_data.pc_to_line_prefix);
1620       Tcl_DStringAppend (&client_data.pc_to_line_prefix,
1621                          prefix, prefix_len);
1622       Tcl_DStringAppend (&client_data.pc_to_line_prefix, ",pc=",
1623                          sizeof (",pc=") - 1);
1624
1625       Tcl_DStringInit(&client_data.line_to_pc_prefix);
1626       Tcl_DStringAppend (&client_data.line_to_pc_prefix,
1627                          prefix, prefix_len);
1628       Tcl_DStringAppend (&client_data.line_to_pc_prefix, ",line=",
1629                          sizeof (",line=") - 1);
1630
1631     }
1632   else
1633     {
1634       client_data.map_arr = "";
1635     }
1636
1637   /* Now parse the addresses */
1638   if (Tcl_GetWideIntFromObj (interp, objv[5], &waddr) != TCL_OK)
1639     return TCL_ERROR;
1640   low = waddr;
1641
1642   orig = low;
1643
1644   if (objc == 6)
1645     {
1646       if (find_pc_partial_function (low, NULL, &low, &high) == 0)
1647         error ("No function contains address 0x%s", core_addr_to_string (orig));
1648     }
1649   else
1650     {
1651       if (Tcl_GetWideIntFromObj (interp, objv[6], &waddr) != TCL_OK)
1652         return TCL_ERROR;
1653       high = waddr;
1654     }
1655
1656   /* Setup the client_data structure, and call the driver function. */
1657
1658   client_data.file_opened_p = 0;
1659   client_data.widget_line_no = 0;
1660   client_data.interp = interp;
1661   for (i = 0; i < 3; i++)
1662     {
1663       client_data.result_obj[i] = Tcl_NewObj();
1664       Tcl_IncrRefCount (client_data.result_obj[i]);
1665     }
1666
1667   /* Fill up the constant parts of the argv structures */
1668   client_data.asm_argv[0] = client_data.widget;
1669   client_data.asm_argv[1] = "insert";
1670   client_data.asm_argv[2] = "end";
1671   client_data.asm_argv[3] = "-\t";
1672   client_data.asm_argv[4] = "break_rgn_tag";
1673   /* client_data.asm_argv[5] = address; */
1674   client_data.asm_argv[6] = "break_rgn_tag";
1675   /* client_data.asm_argv[7] = offset; */
1676   client_data.asm_argv[8] = "break_rgn_tag";
1677   client_data.asm_argv[9] = ":\t\t";
1678   client_data.asm_argv[10] = "source_tag";
1679   /* client_data.asm_argv[11] = code; */
1680   client_data.asm_argv[12] = "source_tag";
1681   client_data.asm_argv[13] = "\n";
1682
1683   if (mixed_source_and_assembly)
1684     {
1685       client_data.source_argv[0] = client_data.widget;
1686       client_data.source_argv[1] = "insert";
1687       client_data.source_argv[2] = "end";
1688       /* client_data.source_argv[3] = line_number; */
1689       client_data.source_argv[4] = "";
1690       /* client_data.source_argv[5] = line; */
1691       client_data.source_argv[6] = "source_tag2";
1692     }
1693
1694   ret_val = gdb_disassemble_driver (low, high, mixed_source_and_assembly,
1695                                     (ClientData) &client_data,
1696                                     gdbtk_load_source, gdbtk_load_asm);
1697
1698   /* Now clean up the opened file, and the Tcl data structures */
1699
1700   if (client_data.file_opened_p == 1)
1701     fclose(client_data.fp);
1702
1703   if (*client_data.map_arr != '\0')
1704     {
1705       Tcl_DStringFree(&client_data.src_to_line_prefix);
1706       Tcl_DStringFree(&client_data.pc_to_line_prefix);
1707       Tcl_DStringFree(&client_data.line_to_pc_prefix);
1708     }
1709
1710   for (i = 0; i < 3; i++)
1711     {
1712       Tcl_DecrRefCount (client_data.result_obj[i]);
1713     }
1714
1715   /* Finally, if we were successful, stick the low & high addresses
1716      into the Tcl result. */
1717
1718   if (ret_val == TCL_OK)
1719     {
1720       Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
1721                                 Tcl_NewStringObj (core_addr_to_string (low), -1));
1722       Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
1723                                 Tcl_NewStringObj (core_addr_to_string (high), -1));
1724     }
1725   return ret_val;
1726 }
1727
1728 static void
1729 gdbtk_load_source (ClientData clientData, struct symtab *symtab,
1730                    int start_line, int end_line)
1731 {
1732   struct disassembly_client_data *client_data =
1733     (struct disassembly_client_data *) clientData;
1734   char *buffer;
1735   int index_len;
1736
1737   index_len = Tcl_DStringLength (&client_data->src_to_line_prefix);
1738
1739   if (client_data->file_opened_p == 1)
1740     {
1741       const char **text_argv;
1742       char line[10000], line_number[18];
1743       int found_carriage_return = 1;
1744
1745       /* First do some sanity checks on the requested lines */
1746
1747       if (start_line < 1
1748           || end_line < start_line || end_line > symtab->nlines)
1749         {
1750           return;
1751         }
1752
1753       line_number[0] = '\t';
1754       line[0] = '\t';
1755
1756       text_argv = client_data->source_argv;
1757
1758       text_argv[3] = line_number;
1759       text_argv[5] = line;
1760
1761       if (fseek (client_data->fp, symtab->line_charpos[start_line - 1],
1762                  SEEK_SET) < 0)
1763         {
1764           fclose(client_data->fp);
1765           client_data->file_opened_p = -1;
1766           return;
1767         }
1768
1769       for (; start_line < end_line; start_line++)
1770         {
1771           if (!fgets (line + 1, 9980, client_data->fp))
1772             {
1773               fclose(client_data->fp);
1774               client_data->file_opened_p = -1;
1775               return;
1776             }
1777
1778           client_data->widget_line_no++;
1779
1780           sprintf (line_number + 1, "%d", start_line);
1781
1782           if (found_carriage_return)
1783             {
1784               char *p = strrchr(line, '\0') - 2;
1785               if (*p == '\r')
1786                 {
1787                   *p = '\n';
1788                   *(p + 1) = '\0';
1789                 }
1790               else
1791                 found_carriage_return = 0;
1792             }
1793
1794           /* Run the command, then add an entry to the map array in
1795              the caller's scope, if requested. */
1796
1797           client_data->cmd.proc (client_data->cmd.clientData,
1798                                  client_data->interp, 7, text_argv);
1799
1800           if (*client_data->map_arr != '\0')
1801             {
1802
1803               Tcl_DStringAppend (&client_data->src_to_line_prefix,
1804                                  line_number + 1, -1);
1805
1806               /* FIXME: Convert to Tcl_SetVar2Ex when we move to 8.2.  This
1807                  will allow us avoid converting widget_line_no into a string. */
1808
1809               xasprintf (&buffer, "%d", client_data->widget_line_no);
1810
1811               Tcl_SetVar2 (client_data->interp, client_data->map_arr,
1812                            Tcl_DStringValue (&client_data->src_to_line_prefix),
1813                            buffer, 0);
1814               free(buffer);
1815
1816               Tcl_DStringSetLength (&client_data->src_to_line_prefix, index_len);
1817             }
1818         }
1819
1820     }
1821   else if (!client_data->file_opened_p)
1822     {
1823       int fdes;
1824       /* The file is not yet open, try to open it, then print the
1825          first line.  If we fail, set FILE_OPEN_P to -1. */
1826
1827       fdes = open_source_file (symtab);
1828       if (fdes < 0)
1829         {
1830           client_data->file_opened_p = -1;
1831         }
1832       else
1833         {
1834           /* FIXME: Convert to a Tcl File Channel and read from there.
1835              This will allow us to get the line endings and conversion
1836              to UTF8 right automatically when we move to 8.2.
1837              Need a Cygwin call to convert a file descriptor to the native
1838              Windows handler to do this. */
1839
1840           client_data->file_opened_p = 1;
1841           client_data->fp = fdopen (fdes, FOPEN_RB);
1842           clearerr (client_data->fp);
1843
1844           if (symtab->line_charpos == 0)
1845             find_source_lines (symtab, fdes);
1846
1847           /* We are called with an actual load request, so call ourselves
1848              to load the first line. */
1849
1850           gdbtk_load_source (clientData, symtab, start_line, end_line);
1851         }
1852     }
1853   else
1854     {
1855       /* If we couldn't open the file, or got some prior error, just exit. */
1856       return;
1857     }
1858 }
1859
1860
1861 /* FIXME: cagney/2003-09-08: "di" is not used and unneeded.  */
1862 static CORE_ADDR
1863 gdbtk_load_asm (ClientData clientData, CORE_ADDR pc,
1864                 struct disassemble_info *di)
1865 {
1866   struct disassembly_client_data * client_data
1867     = (struct disassembly_client_data *) clientData;
1868   const char **text_argv;
1869   int i, pc_to_line_len, line_to_pc_len;
1870   gdbtk_result new_result;
1871   int insn;
1872   struct cleanup *old_chain = NULL;
1873
1874   pc_to_line_len = Tcl_DStringLength (&client_data->pc_to_line_prefix);
1875   line_to_pc_len = Tcl_DStringLength (&client_data->line_to_pc_prefix);
1876
1877   text_argv = client_data->asm_argv;
1878
1879   /* Preserve the current Tcl result object, print out what we need, and then
1880      suck it out of the result, and replace... */
1881
1882   old_chain = make_cleanup (gdbtk_restore_result_ptr, (void *) result_ptr);
1883   result_ptr = &new_result;
1884   result_ptr->obj_ptr = client_data->result_obj[0];
1885   result_ptr->flags = GDBTK_TO_RESULT;
1886
1887   /* Null out the three return objects we will use. */
1888
1889   for (i = 0; i < 3; i++)
1890     Tcl_SetObjLength (client_data->result_obj[i], 0);
1891
1892   fputs_filtered (paddress (pc), gdb_stdout);
1893   gdb_flush (gdb_stdout);
1894
1895   result_ptr->obj_ptr = client_data->result_obj[1];
1896   print_address_symbolic (pc, gdb_stdout, 1, "\t");
1897   gdb_flush (gdb_stdout);
1898
1899   result_ptr->obj_ptr = client_data->result_obj[2];
1900   /* FIXME: cagney/2003-09-08: This should use gdb_disassembly.  */
1901   insn = gdb_print_insn (pc, gdb_stdout, NULL);
1902   gdb_flush (gdb_stdout);
1903
1904   client_data->widget_line_no++;
1905
1906   text_argv[5] = Tcl_GetStringFromObj (client_data->result_obj[0], NULL);
1907   text_argv[7] = Tcl_GetStringFromObj (client_data->result_obj[1], NULL);
1908   text_argv[11] = Tcl_GetStringFromObj (client_data->result_obj[2], NULL);
1909
1910   client_data->cmd.proc (client_data->cmd.clientData,
1911                          client_data->interp, 14, text_argv);
1912
1913   if (*client_data->map_arr != '\0')
1914     {
1915       char *buffer;
1916
1917       /* Run the command, then add an entry to the map array in
1918          the caller's scope. */
1919
1920       Tcl_DStringAppend (&client_data->pc_to_line_prefix, core_addr_to_string (pc), -1);
1921
1922       /* FIXME: Convert to Tcl_SetVar2Ex when we move to 8.2.  This
1923          will allow us avoid converting widget_line_no into a string. */
1924
1925       xasprintf (&buffer, "%d", client_data->widget_line_no);
1926
1927       Tcl_SetVar2 (client_data->interp, client_data->map_arr,
1928                    Tcl_DStringValue (&client_data->pc_to_line_prefix),
1929                    buffer, 0);
1930
1931       Tcl_DStringAppend (&client_data->line_to_pc_prefix, buffer, -1);
1932
1933
1934       Tcl_SetVar2 (client_data->interp, client_data->map_arr,
1935                    Tcl_DStringValue (&client_data->line_to_pc_prefix),
1936                    core_addr_to_string (pc), 0);
1937
1938       /* Restore the prefixes to their initial state. */
1939
1940       Tcl_DStringSetLength (&client_data->pc_to_line_prefix, pc_to_line_len);
1941       Tcl_DStringSetLength (&client_data->line_to_pc_prefix, line_to_pc_len);
1942
1943       xfree (buffer);
1944     }
1945
1946   do_cleanups (old_chain);
1947
1948   return pc + insn;
1949 }
1950
1951 static int
1952 gdb_disassemble_driver (CORE_ADDR low, CORE_ADDR high,
1953                         int mixed_source_and_assembly,
1954                         ClientData clientData,
1955                         void (*print_source_fn) (ClientData, struct symtab *, int, int),
1956                         CORE_ADDR (*print_asm_fn) (ClientData, CORE_ADDR, struct disassemble_info *))
1957 {
1958   CORE_ADDR pc;
1959
1960   /* If just doing straight assembly, all we need to do is disassemble
1961      everything between low and high.  If doing mixed source/assembly, we've
1962      got a totally different path to follow.  */
1963
1964   if (mixed_source_and_assembly)
1965     {                           /* Come here for mixed source/assembly */
1966       /* The idea here is to present a source-O-centric view of a function to
1967          the user.  This means that things are presented in source order, with
1968          (possibly) out of order assembly immediately following.  */
1969       struct symtab *symtab;
1970       struct linetable_entry *le;
1971       int nlines;
1972       int newlines;
1973       struct my_line_entry *mle;
1974       struct symtab_and_line sal;
1975       int i;
1976       int out_of_order;
1977       int next_line;
1978
1979       /* Assume symtab is valid for whole PC range */
1980       symtab = find_pc_symtab (low);
1981
1982       if (!symtab || !symtab->linetable)
1983         goto assembly_only;
1984
1985       /* First, convert the linetable to a bunch of my_line_entry's.  */
1986
1987       le = symtab->linetable->item;
1988       nlines = symtab->linetable->nitems;
1989
1990       if (nlines <= 0)
1991         goto assembly_only;
1992
1993       mle = (struct my_line_entry *) alloca (nlines *
1994                                              sizeof (struct my_line_entry));
1995
1996       out_of_order = 0;
1997
1998       /* Copy linetable entries for this function into our data structure,
1999          creating end_pc's and setting out_of_order as appropriate.  */
2000
2001       /* First, skip all the preceding functions.  */
2002
2003       for (i = 0; i < nlines - 1 && le[i].pc < low; i++) ;
2004
2005       /* Now, copy all entries before the end of this function.  */
2006
2007       newlines = 0;
2008       for (; i < nlines - 1 && le[i].pc < high; i++)
2009         {
2010           if (le[i].line == le[i + 1].line
2011               && le[i].pc == le[i + 1].pc)
2012             continue;           /* Ignore duplicates */
2013
2014           /* Skip any end-of-function markers.  */
2015           if (le[i].line == 0)
2016             continue;
2017
2018           mle[newlines].line = le[i].line;
2019           if (le[i].line > le[i + 1].line)
2020             out_of_order = 1;
2021           mle[newlines].start_pc = le[i].pc;
2022           mle[newlines].end_pc = le[i + 1].pc;
2023           newlines++;
2024         }
2025
2026       /* If we're on the last line, and it's part of the function, then we
2027          need to get the end pc in a special way.  */
2028
2029       if (i == nlines - 1
2030           && le[i].pc < high)
2031         {
2032           mle[newlines].line = le[i].line;
2033           mle[newlines].start_pc = le[i].pc;
2034           sal = find_pc_line (le[i].pc, 0);
2035           mle[newlines].end_pc = sal.end;
2036           newlines++;
2037         }
2038
2039       /* Now, sort mle by line #s (and, then by addresses within lines). */
2040
2041       if (out_of_order)
2042         qsort (mle, newlines, sizeof (struct my_line_entry), compare_lines);
2043
2044       /* Now, for each line entry, emit the specified lines (unless they have
2045          been emitted before), followed by the assembly code for that line.  */
2046
2047       next_line = 0;            /* Force out first line */
2048       for (i = 0; i < newlines; i++)
2049         {
2050           /* Print out everything from next_line to the current line.  */
2051
2052           if (mle[i].line >= next_line)
2053             {
2054               if (next_line != 0)
2055                 print_source_fn (clientData, symtab, next_line,
2056                                  mle[i].line + 1);
2057               else
2058                 print_source_fn (clientData, symtab, mle[i].line,
2059                                  mle[i].line + 1);
2060
2061               next_line = mle[i].line + 1;
2062             }
2063
2064           for (pc = mle[i].start_pc; pc < mle[i].end_pc; )
2065             {
2066               QUIT;
2067               /* FIXME: cagney/2003-09-08: This entire function should
2068                  be replaced by gdb_disassembly.  */
2069               pc = print_asm_fn (clientData, pc, NULL);
2070             }
2071         }
2072     }
2073   else
2074     {
2075     assembly_only:
2076       for (pc = low; pc < high; )
2077         {
2078           QUIT;
2079           /* FIXME: cagney/2003-09-08: This entire function should be
2080              replaced by gdb_disassembly.  */
2081           pc = print_asm_fn (clientData, pc, NULL);
2082         }
2083     }
2084
2085   return TCL_OK;
2086 }
2087
2088 /* This will be passed to qsort to sort the results of the disassembly */
2089
2090 static int
2091 compare_lines (const PTR mle1p, const PTR mle2p)
2092 {
2093   struct my_line_entry *mle1, *mle2;
2094   int val;
2095
2096   mle1 = (struct my_line_entry *) mle1p;
2097   mle2 = (struct my_line_entry *) mle2p;
2098
2099   val = mle1->line - mle2->line;
2100
2101   if (val != 0)
2102     return val;
2103
2104   return mle1->start_pc - mle2->start_pc;
2105 }
2106
2107 /* This implements the TCL command `gdb_loc',
2108
2109 * Arguments:
2110 *    ?symbol? The symbol or address to locate - defaults to pc
2111 * Tcl Return:
2112 *    a list consisting of the following:
2113 *       basename, function name, filename, line number, address, current pc
2114 */
2115
2116 static int
2117 gdb_loc (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
2118 {
2119   char *filename;
2120   struct symtab_and_line sal;
2121   char *fname;
2122   CORE_ADDR pc;
2123
2124   if (objc == 1)
2125     {
2126       /* This function can be called, before the target is properly
2127          set-up, the following prevents an error, by trying to
2128          read_pc when there is no pc to read. It defaults pc,
2129          before the target is connected to the entry point of the
2130          program */
2131       if (!target_has_registers)
2132         {
2133           pc = entry_point_address ();
2134           sal = find_pc_line (pc, 0);
2135         }
2136       else
2137         {
2138           struct frame_info *frame;
2139
2140           frame = get_selected_frame (NULL);
2141
2142           if (get_frame_pc (frame) != read_pc ())
2143             {
2144               /* Note - this next line is not correct on all architectures.
2145                  For a graphical debugger we really want to highlight the
2146                  assembly line that called the next function on the stack.
2147                  Many architectures have the next instruction saved as the
2148                  pc on the stack, so what happens is the next instruction
2149                  is highlighted. FIXME */
2150               pc = get_frame_pc (frame);
2151               find_frame_sal (frame, &sal);
2152             }
2153           else
2154             {
2155               pc = read_pc ();
2156               sal = find_pc_line (pc, 0);
2157             }
2158         }
2159     }
2160   else if (objc == 2)
2161     {
2162       struct symtabs_and_lines sals;
2163       int nelts;
2164
2165       sals = decode_line_spec (Tcl_GetStringFromObj (objv[1], NULL), 1);
2166
2167       nelts = sals.nelts;
2168       sal = sals.sals[0];
2169       free (sals.sals);
2170
2171       if (sals.nelts != 1)
2172         {
2173           gdbtk_set_result (interp, "Ambiguous line spec", -1);
2174           return TCL_ERROR;
2175         }
2176       resolve_sal_pc (&sal);
2177       pc = sal.pc;
2178     }
2179   else
2180     {
2181       Tcl_WrongNumArgs (interp, 1, objv, "?symbol?");
2182       return TCL_ERROR;
2183     }
2184
2185   if (sal.symtab)
2186     Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
2187                               Tcl_NewStringObj (sal.symtab->filename, -1));
2188   else
2189     Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
2190                               Tcl_NewStringObj ("", 0));
2191
2192   fname = pc_function_name (pc);
2193   Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
2194                             Tcl_NewStringObj (fname, -1));
2195
2196   filename = symtab_to_filename (sal.symtab);
2197   if (filename == NULL)
2198     filename = "";
2199
2200   /* file name */
2201   Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr, Tcl_NewStringObj (filename, -1));
2202   /* line number */
2203   Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr, Tcl_NewIntObj (sal.line));
2204   /* PC in current frame */
2205   Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
2206                             Tcl_NewStringObj (core_addr_to_string (pc), -1));
2207   /* Real PC */
2208   Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
2209                             Tcl_NewStringObj (core_addr_to_string (stop_pc), -1));
2210   /* shared library */
2211 #ifdef PC_SOLIB
2212   Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
2213                             Tcl_NewStringObj (PC_SOLIB (pc), -1));
2214 #else
2215   Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
2216                             Tcl_NewStringObj ("", -1));
2217 #endif
2218   return TCL_OK;
2219 }
2220
2221 /* This implements the TCL command gdb_entry_point.  It returns the current
2222    entry point address.  */
2223
2224 static int
2225 gdb_entry_point (ClientData clientData, Tcl_Interp *interp,
2226                  int objc, Tcl_Obj *CONST objv[])
2227 {
2228   char *addrstr;
2229
2230   /* If we have not yet loaded an exec file, then we have no
2231      entry point, so return an empty string.*/
2232   if ((int) current_target.to_stratum > (int) dummy_stratum)
2233     {
2234       addrstr = (char *)core_addr_to_string (entry_point_address ());
2235       Tcl_SetStringObj (result_ptr->obj_ptr, addrstr, -1);
2236     }
2237   else
2238     Tcl_SetStringObj (result_ptr->obj_ptr, "", -1);
2239
2240   return TCL_OK;
2241 }
2242
2243 /* Covert hex to binary. Stolen from remote.c,
2244    but added error handling */
2245 static int
2246 fromhex (int a)
2247 {
2248   if (a >= '0' && a <= '9')
2249     return a - '0';
2250   else if (a >= 'a' && a <= 'f')
2251     return a - 'a' + 10;
2252   else if (a >= 'A' && a <= 'F')
2253     return a - 'A' + 10;
2254
2255   return -1;
2256 }
2257
2258 static int
2259 hex2bin (const char *hex, char *bin, int count)
2260 {
2261   int i, m, n;
2262   int incr = 2;
2263
2264
2265   if (gdbarch_byte_order (current_gdbarch) == BFD_ENDIAN_LITTLE)
2266     {
2267       /* need to read string in reverse */
2268       hex += count - 2;
2269       incr = -2;
2270     }
2271
2272   for (i = 0; i < count; i += 2)
2273     {
2274       if (hex[0] == 0 || hex[1] == 0)
2275         {
2276           /* Hex string is short, or of uneven length.
2277              Return the count that has been converted so far. */
2278           return i;
2279         }
2280       m = fromhex (hex[0]);
2281       n = fromhex (hex[1]);
2282       if (m == -1 || n == -1)
2283         return -1;
2284       *bin++ = m * 16 + n;
2285       hex += incr;
2286     }
2287
2288   return i;
2289 }
2290
2291 /* This implements the Tcl command 'gdb_set_mem', which
2292  * sets some chunk of memory.
2293  *
2294  * Arguments:
2295  *   gdb_set_mem addr hexstr len
2296  *
2297  *   addr:   address of data to set
2298  *   hexstr: ascii string of data to set
2299  *   len:    number of bytes of data to set
2300  */
2301 static int
2302 gdb_set_mem (ClientData clientData, Tcl_Interp *interp,
2303              int objc, Tcl_Obj *CONST objv[])
2304 {
2305   CORE_ADDR addr;
2306   gdb_byte buf[128];
2307   char *hexstr;
2308   int len, size;
2309
2310   if (objc != 4)
2311     {
2312       Tcl_WrongNumArgs (interp, 1, objv, "addr hex_data len");
2313       return TCL_ERROR;
2314     }
2315
2316   /* Address to write */
2317   addr = string_to_core_addr (Tcl_GetStringFromObj (objv[1], NULL));
2318
2319   /* String value to write: it's in hex */
2320   hexstr = Tcl_GetStringFromObj (objv[2], NULL);
2321   if (hexstr == NULL)
2322     return TCL_ERROR;
2323
2324   /* Length of buf */
2325   if (Tcl_GetIntFromObj (interp, objv[3], &len) != TCL_OK)
2326     return TCL_ERROR;
2327
2328   /* Convert hexstr to binary and write */
2329   if (hexstr[0] == '0' && hexstr[1] == 'x')
2330     hexstr += 2;
2331   size = hex2bin (hexstr, (char *) buf, strlen (hexstr));
2332   if (size < 0)
2333     {
2334       /* Error in input */
2335       gdbtk_set_result (interp, "Invalid hexadecimal input: \"0x%s\"", hexstr);
2336       return TCL_ERROR;
2337     }
2338
2339   target_write_memory (addr, buf, len);
2340   return TCL_OK;
2341 }
2342
2343 /* This implements the Tcl command 'gdb_update_mem', which
2344  * updates a block of memory in the memory window
2345  *
2346  * Arguments:
2347  *   gdb_update_mem data addr form size nbytes bpr aschar
2348  *
2349  *   1 data: variable that holds table's data
2350  *   2 addr: address of data to dump
2351  *   3 mform: a char indicating format
2352  *   4 size: size of each element; 1,2,4, or 8 bytes
2353  *   5 nbytes: the number of bytes to read
2354  *   6 bpr: bytes per row
2355  *   7 aschar: if present, an ASCII dump of the row is included.  ASCHAR
2356  *              used for unprintable characters.
2357  *
2358  * Return:
2359  * a list of three integers: {border_col_width data_col_width ascii_col_width}
2360  * which can be used to set the table's column widths. */
2361
2362 static int
2363 gdb_update_mem (ClientData clientData, Tcl_Interp *interp,
2364                 int objc, Tcl_Obj *CONST objv[])
2365 {
2366   long dummy;
2367   char index[20];
2368   CORE_ADDR addr;
2369   int nbytes, rnum, bpr;
2370   int size, asize, i, j, bc;
2371   int max_ascii_len, max_val_len, max_label_len;
2372   char format, aschar;
2373   char *data, *tmp;
2374   char buff[128], *mbuf, *mptr, *cptr, *bptr;
2375   struct ui_file *stb;
2376   struct type *val_type;
2377   struct cleanup *old_chain;
2378
2379   if (objc < 7 || objc > 8)
2380     {
2381       Tcl_WrongNumArgs (interp, 1, objv, "data addr format size bytes bytes_per_row ?ascii_char?");
2382       return TCL_ERROR;
2383     }
2384
2385   /* Get table data and link to a local variable */
2386   data = Tcl_GetStringFromObj (objv[1], NULL);
2387   if (data == NULL)
2388     {
2389       gdbtk_set_result (interp, "could not get data variable");
2390       return TCL_ERROR;
2391     }
2392
2393   if (Tcl_UpVar (interp, "1", data, "data", 0) != TCL_OK)
2394     {
2395       gdbtk_set_result (interp, "could not link table data");
2396       return TCL_ERROR;
2397     }
2398
2399   if (Tcl_GetIntFromObj (interp, objv[4], &size) != TCL_OK)
2400     return TCL_ERROR;
2401   else if (size <= 0)
2402     {
2403       gdbtk_set_result (interp, "Invalid size, must be > 0");
2404       return TCL_ERROR;
2405     }
2406
2407   if (Tcl_GetIntFromObj (interp, objv[5], &nbytes) != TCL_OK)
2408     return TCL_ERROR;
2409   else if (nbytes <= 0)
2410     {
2411       gdbtk_set_result (interp, "Invalid number of bytes, must be > 0");
2412       return TCL_ERROR;
2413     }
2414
2415   if (Tcl_GetIntFromObj (interp, objv[6], &bpr) != TCL_OK)
2416     return TCL_ERROR;
2417   else if (bpr <= 0)
2418     {
2419       gdbtk_set_result (interp, "Invalid bytes per row, must be > 0");
2420       return TCL_ERROR;
2421     }
2422
2423   tmp = Tcl_GetStringFromObj (objv[2], NULL);
2424   if (tmp == NULL)
2425     {
2426       gdbtk_set_result (interp, "could not get address");
2427       return TCL_ERROR;
2428     }
2429   addr = string_to_core_addr (tmp);
2430
2431   format = *(Tcl_GetStringFromObj (objv[3], NULL));
2432   mbuf = (char *) xmalloc (nbytes + 32);
2433   if (!mbuf)
2434     {
2435       gdbtk_set_result (interp, "Out of memory.");
2436       return TCL_ERROR;
2437     }
2438
2439   memset (mbuf, 0, nbytes + 32);
2440   mptr = cptr = mbuf;
2441
2442   rnum = target_read (&current_target, TARGET_OBJECT_MEMORY, NULL,
2443                       mbuf, addr, nbytes);
2444   if (rnum <= 0)
2445     {
2446       gdbtk_set_result (interp, "Unable to read memory.");
2447       return TCL_ERROR;
2448     }
2449
2450   if (objc == 8)
2451     aschar = *(Tcl_GetStringFromObj (objv[7], NULL));
2452   else
2453     aschar = 0;
2454
2455   switch (size)
2456     {
2457     case 1:
2458       val_type = builtin_type_int8;
2459       asize = 'b';
2460       break;
2461     case 2:
2462       val_type = builtin_type_int16;
2463       asize = 'h';
2464       break;
2465     case 4:
2466       val_type = builtin_type_int32;
2467       asize = 'w';
2468       break;
2469     case 8:
2470       val_type = builtin_type_int64;
2471       asize = 'g';
2472       break;
2473     default:
2474       val_type = builtin_type_int8;
2475       asize = 'b';
2476     }
2477
2478   bc = 0;                       /* count of bytes in a row */
2479   bptr = &buff[0];              /* pointer for ascii dump */
2480
2481   /* Open a memory ui_file that we can use to print memory values */
2482   stb = mem_fileopen ();
2483   old_chain = make_cleanup_ui_file_delete (stb);
2484
2485   /* A little macro to do column indices. As a rule, given the current
2486      byte, i, of a total nbytes and the bytes per row, bpr, and the size of
2487      each cell, size, the row and column will be given by:
2488
2489      row = i/bpr
2490      col = (i%bpr)/size
2491   */
2492 #define INDEX(row,col) sprintf (index, "%d,%d",(row),(col))
2493
2494   /* Fill in address labels */
2495   max_label_len = 0;
2496   for (i = 0; i < nbytes; i += bpr)
2497     {
2498       char s[130];
2499       sprintf (s, "%s", core_addr_to_string (addr + i));
2500       INDEX ((int) i/bpr, -1);
2501       Tcl_SetVar2 (interp, "data", index, s, 0);
2502
2503       /* The tcl code in MemWin::update_addr used to track the size
2504          of each cell. I don't see how these could change for any given
2505          update, so we don't loop over all cells. We just note the first
2506          size. */
2507       if (max_label_len == 0)
2508         max_label_len = strlen (s);
2509     }
2510
2511   /* Fill in memory */
2512   max_val_len   = 0;            /* Ditto the above comments about max_label_len */
2513   max_ascii_len = 0;
2514   for (i = 0; i < nbytes; i += size)
2515     {
2516       INDEX ((int) i/bpr, (int) (i%bpr)/size);
2517
2518       if (i >= rnum)
2519         {
2520           /* Read fewer bytes than requested */
2521           tmp = "N/A";
2522
2523           if (aschar)
2524             {
2525               for (j = 0; j < size; j++)
2526                 *bptr++ = 'X';
2527             }
2528         }
2529       else
2530         {
2531           /* print memory to our uiout file and set the table's variable */
2532           ui_file_rewind (stb);
2533           print_scalar_formatted (mptr, val_type, format, asize, stb);
2534           tmp = ui_file_xstrdup (stb, &dummy);
2535
2536           /* See comments above on max_*_len */
2537           if (max_val_len == 0)
2538             max_val_len = strlen (tmp);
2539
2540           if (aschar)
2541             {
2542               for (j = 0; j < size; j++)
2543                 {
2544                   if (isprint (*cptr))
2545                     *bptr++ = *cptr++;
2546                   else
2547                     {
2548                       *bptr++ = aschar;
2549                       cptr++;;
2550                     }
2551                 }
2552             }
2553         }
2554       Tcl_SetVar2 (interp, "data", index, tmp, 0);
2555
2556       mptr += size;
2557       bc += size;
2558
2559       if (aschar && (bc >= bpr))
2560         {
2561           /* end of row. Add it to the result and reset variables */
2562           *bptr = '\000';
2563           INDEX (i/bpr, bpr/size);
2564           Tcl_SetVar2 (interp, "data", index, buff, 0);
2565
2566           /* See comments above on max_*_len */
2567           if (max_ascii_len == 0)
2568             max_ascii_len = strlen (buff);
2569
2570           bc = 0;
2571           bptr = &buff[0];
2572         }
2573     }
2574
2575   /* return max_*_len so that column widths can be set */
2576   Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr, Tcl_NewIntObj (max_label_len + 1));
2577   Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr, Tcl_NewIntObj (max_val_len + 1));
2578   Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr, Tcl_NewIntObj (max_ascii_len + 1));
2579   do_cleanups (old_chain);
2580   xfree (mbuf);
2581   return TCL_OK;
2582 #undef INDEX
2583 }
2584 \f
2585
2586 /* This implements the tcl command "gdb_loadfile"
2587  * It loads a c source file into a text widget.
2588  *
2589  * Tcl Arguments:
2590  *    widget: the name of the text widget to fill
2591  *    filename: the name of the file to load
2592  *    linenumbers: A boolean indicating whether or not to display line numbers.
2593  * Tcl Result:
2594  *
2595  */
2596
2597 /* In this routine, we will build up a "line table", i.e. a
2598  * table of bits showing which lines in the source file are executible.
2599  * LTABLE_SIZE is the number of bytes to allocate for the line table.
2600  *
2601  * Its size limits the maximum number of lines
2602  * in a file to 8 * LTABLE_SIZE.  This memory is freed after
2603  * the file is loaded, so it is OK to make this very large.
2604  * Additional memory will be allocated if needed. */
2605 #define LTABLE_SIZE 20000
2606 static int
2607 gdb_loadfile (ClientData clientData, Tcl_Interp *interp, int objc,
2608               Tcl_Obj *CONST objv[])
2609 {
2610   char *file, *widget;
2611   int linenumbers, ln, lnum, ltable_size;
2612   FILE *fp;
2613   char *ltable;
2614   struct symtab *symtab;
2615   struct linetable_entry *le;
2616   long mtime = 0;
2617   struct stat st;
2618   char line[10000], line_num_buf[18];
2619   const char *text_argv[9];
2620   Tcl_CmdInfo text_cmd;
2621
2622
2623   if (objc != 4)
2624     {
2625       Tcl_WrongNumArgs(interp, 1, objv, "widget filename linenumbers");
2626       return TCL_ERROR;
2627     }
2628
2629   widget = Tcl_GetStringFromObj (objv[1], NULL);
2630   if ( Tk_NameToWindow (interp, widget, Tk_MainWindow (interp)) == NULL)
2631     {
2632       return TCL_ERROR;
2633     }
2634
2635   if (!Tcl_GetCommandInfo (interp, widget, &text_cmd))
2636     {
2637       gdbtk_set_result (interp, "Can't get widget command info");
2638       return TCL_ERROR;
2639     }
2640
2641   file  = Tcl_GetStringFromObj (objv[2], NULL);
2642   Tcl_GetBooleanFromObj (interp, objv[3], &linenumbers);
2643
2644   symtab = lookup_symtab (file);
2645   if (!symtab)
2646     {
2647       gdbtk_set_result (interp, "File not found in symtab");
2648       return TCL_ERROR;
2649     }
2650
2651   file = symtab_to_filename ( symtab );
2652   if ((fp = fopen ( file, "r" )) == NULL)
2653     {
2654       gdbtk_set_result (interp, "Can't open file for reading");
2655       return TCL_ERROR;
2656     }
2657
2658   if (stat (file, &st) < 0)
2659     {
2660       catch_errors (perror_with_name_wrapper, "gdbtk: get time stamp", "",
2661                     RETURN_MASK_ALL);
2662       return TCL_ERROR;
2663     }
2664
2665   if (symtab && symtab->objfile && symtab->objfile->obfd)
2666     mtime = bfd_get_mtime(symtab->objfile->obfd);
2667   else if (exec_bfd)
2668     mtime = bfd_get_mtime(exec_bfd);
2669
2670   if (mtime && mtime < st.st_mtime)
2671     {
2672       gdbtk_ignorable_warning("file_times",\
2673                               "Source file is more recent than executable.\n");
2674     }
2675
2676
2677   /* Source linenumbers don't appear to be in order, and a sort is */
2678   /* too slow so the fastest solution is just to allocate a huge */
2679   /* array and set the array entry for each linenumber */
2680
2681   ltable_size = LTABLE_SIZE;
2682   ltable = (char *)malloc (LTABLE_SIZE);
2683   if (ltable == NULL)
2684     {
2685       fclose (fp);
2686       gdbtk_set_result (interp, "Out of memory.");
2687       return TCL_ERROR;
2688     }
2689
2690   memset (ltable, 0, LTABLE_SIZE);
2691
2692   if (symtab->linetable && symtab->linetable->nitems)
2693     {
2694       le = symtab->linetable->item;
2695       for (ln = symtab->linetable->nitems ;ln > 0; ln--, le++)
2696         {
2697           lnum = le->line >> 3;
2698           if (lnum >= ltable_size)
2699             {
2700               char *new_ltable;
2701               new_ltable = (char *)realloc (ltable, ltable_size*2);
2702               memset (new_ltable + ltable_size, 0, ltable_size);
2703               ltable_size *= 2;
2704               if (new_ltable == NULL)
2705                 {
2706                   free (ltable);
2707                   fclose (fp);
2708                   gdbtk_set_result (interp, "Out of memory.");
2709                   return TCL_ERROR;
2710                 }
2711               ltable = new_ltable;
2712             }
2713           ltable[lnum] |= 1 << (le->line % 8);
2714         }
2715     }
2716
2717   ln = 1;
2718
2719   line[0] = '\t';
2720   text_argv[0] = widget;
2721   text_argv[1] = "insert";
2722   text_argv[2] = "end";
2723   text_argv[5] = line;
2724   text_argv[6] = "source_tag";
2725   text_argv[8] = NULL;
2726
2727   if (linenumbers)
2728     {
2729       int found_carriage_return = 1;
2730
2731       line_num_buf[1] = '\t';
2732
2733       text_argv[3] = line_num_buf;
2734
2735       while (fgets (line + 1, 9980, fp))
2736         {
2737           /* Look for DOS style \r\n endings, and if found,
2738            * strip off the \r.  We assume (for the sake of
2739            * speed) that ALL lines in the file have DOS endings,
2740            * or none do.
2741            */
2742
2743           if (found_carriage_return)
2744             {
2745               char *p = strrchr(line, '\0') - 2;
2746               if (*p == '\r')
2747                 {
2748                   *p = '\n';
2749                   *(p + 1) = '\0';
2750                 }
2751               else
2752                 found_carriage_return = 0;
2753             }
2754
2755           sprintf (line_num_buf+2, "%d", ln);
2756           if (ltable[ln >> 3] & (1 << (ln % 8)))
2757             {
2758               line_num_buf[0] = '-';
2759               text_argv[4] = "break_rgn_tag";
2760             }
2761           else
2762             {
2763               line_num_buf[0] = ' ';
2764               text_argv[4] = "";
2765             }
2766
2767           text_cmd.proc(text_cmd.clientData, interp, 7, text_argv);
2768           ln++;
2769         }
2770     }
2771   else
2772     {
2773       int found_carriage_return = 1;
2774
2775       while (fgets (line + 1, 9980, fp))
2776         {
2777           if (found_carriage_return)
2778             {
2779               char *p = strrchr(line, '\0') - 2;
2780               if (*p == '\r')
2781                 {
2782                   *p = '\n';
2783                   *(p + 1) = '\0';
2784                 }
2785               else
2786                 found_carriage_return = 0;
2787             }
2788
2789           if (ltable[ln >> 3] & (1 << (ln % 8)))
2790             {
2791               text_argv[3] = "- ";
2792               text_argv[4] = "break_rgn_tag";
2793             }
2794           else
2795             {
2796               text_argv[3] = "  ";
2797               text_argv[4] = "";
2798             }
2799
2800           text_cmd.proc(text_cmd.clientData, interp, 7, text_argv);
2801           ln++;
2802         }
2803     }
2804
2805   free (ltable);
2806   fclose (fp);
2807   return TCL_OK;
2808 }
2809 \f
2810 /*
2811  * This section contains a bunch of miscellaneous utility commands
2812  */
2813
2814 /* This implements the tcl command gdb_path_conv
2815
2816 * On Windows, it canonicalizes the pathname,
2817 * On Unix, it is a no op.
2818 *
2819 * Arguments:
2820 *    path
2821 * Tcl Result:
2822 *    The canonicalized path.
2823 */
2824
2825 static int
2826 gdb_path_conv (ClientData clientData, Tcl_Interp *interp,
2827                int objc, Tcl_Obj *CONST objv[])
2828 {
2829   if (objc != 2)
2830     {
2831       Tcl_WrongNumArgs (interp, 1, objv, NULL);
2832       return TCL_ERROR;
2833     }
2834
2835 #ifdef __CYGWIN__
2836   {
2837     char pathname[256], *ptr;
2838
2839     cygwin_conv_to_full_win32_path (Tcl_GetStringFromObj (objv[1], NULL),
2840                                       pathname);
2841     for (ptr = pathname; *ptr; ptr++)
2842       {
2843         if (*ptr == '\\')
2844           *ptr = '/';
2845       }
2846     Tcl_SetStringObj (result_ptr->obj_ptr, pathname, -1);
2847   }
2848 #else
2849   Tcl_SetStringObj (result_ptr->obj_ptr, Tcl_GetStringFromObj (objv[1], NULL),
2850                     -1);
2851 #endif
2852
2853   return TCL_OK;
2854 }
2855 \f
2856 /*
2857  * This section has utility routines that are not Tcl commands.
2858  */
2859
2860 static int
2861 perror_with_name_wrapper (PTR args)
2862 {
2863   perror_with_name (args);
2864   return 1;
2865 }
2866
2867 /* Look for the function that contains PC and return the source
2868    (demangled) name for this function.
2869
2870    If no symbol is found, it returns an empty string. In either
2871    case, memory is owned by gdb. Do not attempt to free it. */
2872 char *
2873 pc_function_name (CORE_ADDR pc)
2874 {
2875   struct symbol *sym;
2876   char *funcname = NULL;
2877
2878   /* First lookup the address in the symbol table... */
2879   sym = find_pc_function (pc);
2880   if (sym != NULL)
2881     funcname = GDBTK_SYMBOL_SOURCE_NAME (sym);
2882   else
2883     {
2884       /* ... if that fails, look it up in the minimal symbols. */
2885       struct minimal_symbol *msym = NULL;
2886
2887       msym = lookup_minimal_symbol_by_pc (pc);
2888       if (msym != NULL)
2889         funcname = GDBTK_SYMBOL_SOURCE_NAME (msym);
2890     }
2891
2892   if (funcname == NULL)
2893     funcname = "";
2894
2895   return funcname;
2896 }
2897
2898 void
2899 gdbtk_set_result (Tcl_Interp *interp, const char *fmt,...)
2900 {
2901   va_list args;
2902   char *buf;
2903
2904   va_start (args, fmt);
2905   xvasprintf (&buf, fmt, args);
2906   va_end (args);
2907   Tcl_SetObjResult (interp, Tcl_NewStringObj (buf, -1));
2908   xfree(buf);
2909 }
2910
2911
2912 /* This implements the tcl command 'gdb_incr_addr'.
2913  * It does address arithmetic and outputs a proper
2914  * hex string.  This was originally implemented
2915  * when tcl did not support 64-bit values, but we keep
2916  * it because it saves us from having to call incr
2917  * followed by format to get the result in hex.
2918  * Also, it may be true in the future that CORE_ADDRs
2919  * will have their own ALU to deal properly with
2920  * architecture-specific address arithmetic.
2921  *
2922  * Tcl Arguments:
2923  *     addr   - CORE_ADDR
2924  *     number - optional number to add to the address
2925  *      default is 1.
2926  *
2927  * Tcl Result:
2928  *     hex string containing the result of addr + number
2929  */
2930
2931 static int
2932 gdb_incr_addr (ClientData clientData, Tcl_Interp *interp,
2933                int objc, Tcl_Obj *CONST objv[])
2934 {
2935   CORE_ADDR address;
2936   int number = 1;
2937
2938   if (objc != 2 && objc != 3)
2939     {
2940       Tcl_WrongNumArgs (interp, 1, objv, "CORE_ADDR [number]");
2941       return TCL_ERROR;
2942     }
2943
2944   address = string_to_core_addr (Tcl_GetStringFromObj (objv[1], NULL));
2945
2946   if (objc == 3)
2947     {
2948       if (Tcl_GetIntFromObj (interp, objv[2], &number) != TCL_OK)
2949         return TCL_ERROR;
2950     }
2951
2952   address += number;
2953
2954   Tcl_SetStringObj (result_ptr->obj_ptr, (char *)core_addr_to_string (address), -1);
2955
2956   return TCL_OK;
2957 }
2958
2959 /* This implements the tcl command 'gdb_CAS_to_TAS'.
2960  * It takes a CORE_ADDR and outputs a string suitable
2961  * for displaying as the target address.
2962  *
2963  * Note that CORE_ADDRs are internal addresses which map
2964  * to target addresses in different ways depending on the
2965  * architecture. The target address string is a user-readable
2966  * string may be quite different than the CORE_ADDR. For example,
2967  * a CORE_ADDR of 0x02001234 might indicate a data address of
2968  * 0x1234 which this function might someday output as something
2969  * like "D:1234".
2970  *
2971  * Tcl Arguments:
2972  *     address   - CORE_ADDR
2973  *
2974  * Tcl Result:
2975  *     string
2976  */
2977
2978 static int
2979 gdb_CA_to_TAS (ClientData clientData, Tcl_Interp *interp,
2980                int objc, Tcl_Obj *CONST objv[])
2981 {
2982   CORE_ADDR address;
2983   Tcl_WideInt wide_addr;
2984
2985   if (objc != 2)
2986     {
2987       Tcl_WrongNumArgs (interp, 1, objv, "CORE_ADDR");
2988       return TCL_ERROR;
2989     }
2990
2991   /* Read address into a wideint, which is the largest tcl supports
2992      then convert to a CORE_ADDR */
2993   if (Tcl_GetWideIntFromObj (interp, objv[1], &wide_addr) != TCL_OK)
2994     return TCL_ERROR;
2995   address = wide_addr;
2996
2997   /* This is not really correct.  Using paddr_nz() will convert to hex and truncate
2998      to 32-bits when required but will otherwise not do what we really want. */
2999   Tcl_SetStringObj (result_ptr->obj_ptr, paddr_nz (address), -1);
3000
3001   return TCL_OK;
3002 }
3003
3004 /* Another function that was removed in GDB and replaced
3005  * with something similar, but different enough to break
3006  * Insight.
3007  */
3008 char *
3009 symtab_to_filename (struct symtab *s)
3010 {
3011   int r;
3012
3013   if (!s)
3014     return NULL;
3015
3016   /* Don't check s->fullname here, the file could have been
3017      deleted/moved/..., look for it again */
3018   r = open_source_file (s);
3019   if (r)
3020     close (r);
3021
3022   if (s->fullname && *s->fullname)
3023       return s->fullname;
3024   return s->filename;
3025 }