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