gdb/gdbtk.c

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