1999-02-02 Martin Hunt <hunt@cygnus.com>

[deliverable/binutils-gdb.git] / gdb / gdbtk-cmds.c

/* Tcl/Tk command definitions for gdbtk.
   Copyright 1994, 1995, 1996, 1997, 1998 Free Software Foundation, Inc.

   Written by Stu Grossman <grossman@cygnus.com> of Cygnus Support.

This file is part of GDB.

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.  */

#include "defs.h"
#include "symtab.h"
#include "inferior.h"
#include "command.h"
#include "bfd.h"
#include "symfile.h"
#include "objfiles.h"
#include "target.h"
#include "gdbcore.h"
#include "tracepoint.h"
#include "demangle.h"

#ifdef _WIN32
#include <winuser.h>
#endif

#include <sys/stat.h>

#include <tcl.h>
#include <tk.h>
#include <itcl.h> 
#include <tix.h> 
#include "guitcl.h"
#include "gdbtk.h"

/* start-sanitize-ide */
#ifdef IDE
#include "event.h"
#include "idetcl.h"
#include "ilutk.h"
#endif
/* end-sanitize-ide */

#ifdef ANSI_PROTOTYPES
#include <stdarg.h>
#else
#include <varargs.h>
#endif
#include <signal.h>
#include <fcntl.h>
#include <unistd.h>
#include <setjmp.h>
#include "top.h"
#include <sys/ioctl.h>
#include "gdb_string.h"
#include "dis-asm.h"
#include <stdio.h>
#include "gdbcmd.h"

#include "annotate.h"
#include <sys/time.h>

/* This structure filled in call_wrapper and passed to
   the wrapped call function.
   It stores the command pointer and arguments 
   run in the wrapper function. */

struct wrapped_call_args
{
  Tcl_Interp *interp;
  Tcl_ObjCmdProc *func;
  int objc;
  Tcl_Obj *CONST *objv;
  int val;
};

/* These two objects hold boolean true and false,
   and are shared by all the list objects that gdb_listfuncs
   returns. */
   
static Tcl_Obj *mangled, *not_mangled;

/* These two control how the GUI behaves when gdb is either tracing or loading.
   They are used in this file & gdbtk_hooks.c */

int No_Update = 0;
int load_in_progress = 0;

/*
 * This is used in the register fetching routines
 */

#ifndef REGISTER_CONVERTIBLE
#define REGISTER_CONVERTIBLE(x) (0 != 0)
#endif

#ifndef REGISTER_CONVERT_TO_VIRTUAL
#define REGISTER_CONVERT_TO_VIRTUAL(x, y, z, a)
#endif

#ifndef INVALID_FLOAT
#define INVALID_FLOAT(x, y) (0 != 0)
#endif



/* This Structure is used in gdb_disassemble.
   We need a different sort of line table from the normal one cuz we can't
   depend upon implicit line-end pc's for lines to do the
   reordering in this function.  */

struct my_line_entry {
  int line;
  CORE_ADDR start_pc;
  CORE_ADDR end_pc;
};

/* This contains the previous values of the registers, since the last call to
   gdb_changed_register_list.  */

static char old_regs[REGISTER_BYTES];

/* These two lookup tables are used to translate the type & disposition fields
   of the breakpoint structure (respectively) into something gdbtk understands.
   They are also used in gdbtk-hooks.c */

char *bptypes[] = {"none", "breakpoint", "hw breakpoint", "until",
                   "finish", "watchpoint", "hw watchpoint",
                   "read watchpoint", "acc watchpoint",
                   "longjmp", "longjmp resume", "step resume",
                   "sigtramp", "watchpoint scope",
                   "call dummy", "shlib events", "catch load",
                   "catch unload", "catch fork", "catch vfork",
                   "catch exec", "catch catch", "catch throw"
};
char *bpdisp[] = {"delete", "delstop", "disable", "donttouch"};

/*
 * These are routines we need from breakpoint.c.
 * at some point make these static in breakpoint.c and move GUI code there
 */

extern struct breakpoint *set_raw_breakpoint (struct symtab_and_line sal);
extern void set_breakpoint_count (int);
extern int breakpoint_count;

/* This variable determines where memory used for disassembly is read from.
 * See note in gdbtk.h for details.
 */
int disassemble_from_exec = -1;

extern int gdb_variable_init PARAMS ((Tcl_Interp *interp));

/*
 * Declarations for routines exported from this file
 */

int Gdbtk_Init (Tcl_Interp *interp);
int call_wrapper PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));

/*
 * Declarations for routines used only in this file.
 */

static int compare_lines PARAMS ((const PTR, const PTR));
static int comp_files PARAMS ((const void *, const void *));
static int gdb_actions_command PARAMS ((ClientData, Tcl_Interp *, int,
                                        Tcl_Obj *CONST objv[]));
static int gdb_changed_register_list PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
static int gdb_clear_file PARAMS ((ClientData, Tcl_Interp *interp, int, Tcl_Obj *CONST []));
static int gdb_cmd PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
static int gdb_confirm_quit PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
static int gdb_disassemble PARAMS ((ClientData, Tcl_Interp *, int, 
                                    Tcl_Obj *CONST []));
static int gdb_eval PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
static int gdb_fetch_registers PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
static int gdb_find_file_command PARAMS ((ClientData, Tcl_Interp *, int,
                                          Tcl_Obj *CONST objv[]));
static int gdb_force_quit PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
static struct symtab *full_lookup_symtab PARAMS ((char *file));
static int gdb_get_args_command PARAMS ((ClientData, Tcl_Interp *, int,
                                         Tcl_Obj *CONST objv[]));
static int gdb_get_breakpoint_info PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
static int gdb_get_breakpoint_list PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
static int gdb_get_file_command PARAMS ((ClientData, Tcl_Interp *, int,
                                         Tcl_Obj *CONST objv[]));
static int gdb_get_function_command PARAMS ((ClientData, Tcl_Interp *, int,
                                             Tcl_Obj *CONST objv[]));
static int gdb_get_line_command PARAMS ((ClientData, Tcl_Interp *, int,
                                         Tcl_Obj *CONST objv[]));
static int gdb_get_locals_command PARAMS ((ClientData, Tcl_Interp *, int,
                                         Tcl_Obj *CONST objv[]));
static int gdb_get_mem PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
static int gdb_get_trace_frame_num PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST objv[]));
static int gdb_get_tracepoint_list PARAMS ((ClientData, Tcl_Interp *, int,
                                            Tcl_Obj *CONST objv[]));
static int gdb_get_vars_command PARAMS ((ClientData, Tcl_Interp *, int,
                                         Tcl_Obj *CONST objv[]));
static int gdb_immediate_command PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
static int gdb_listfiles PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
static int gdb_listfuncs PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
static int gdb_loadfile PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST objv[]));
static int gdb_load_info PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST objv[]));
static int gdb_loc PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
static int gdb_path_conv PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
static int gdb_prompt_command PARAMS ((ClientData, Tcl_Interp *, int,
                                       Tcl_Obj *CONST objv[]));
static int gdb_regnames PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
static int gdb_search PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST
                               objv[]));
static int gdb_set_bp PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST objv[]));
static int gdb_set_bp_addr PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST objv[]));
static int gdb_find_bp_at_line PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST objv[]));
static int gdb_find_bp_at_addr PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST objv[]));
static int gdb_stop PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
static int gdb_target_has_execution_command PARAMS ((ClientData, Tcl_Interp *,
                                                     int,
                                                     Tcl_Obj *CONST []));
static int gdb_trace_status PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
static int gdb_tracepoint_exists_command PARAMS ((ClientData, Tcl_Interp *,
                                                  int,
                                                  Tcl_Obj *CONST objv[]));
static int gdb_get_tracepoint_info PARAMS ((ClientData, Tcl_Interp *, int,
                                            Tcl_Obj *CONST objv[]));
static int gdbtk_dis_asm_read_memory PARAMS ((bfd_vma, bfd_byte *, int, disassemble_info *));
static int get_pc_register PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
static int gdb_stack PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));

char * get_prompt PARAMS ((void));
static void get_register PARAMS ((int, void *));
static void get_register_name PARAMS ((int, void *));
static int map_arg_registers PARAMS ((int, Tcl_Obj *CONST [], void (*) (int, void *), void *));
static int perror_with_name_wrapper PARAMS ((char *args));
static void register_changed_p PARAMS ((int, void *));
void TclDebug PARAMS ((const char *fmt, ...));
static int wrapped_call (char *opaque_args);
static void get_frame_name PARAMS ((Tcl_Interp *interp, Tcl_Obj *list, struct frame_info *fi));
\f
/* Gdbtk_Init
 *    This loads all the Tcl commands into the Tcl interpreter.
 *
 * Arguments:
 *    interp - The interpreter into which to load the commands.
 *
 * Result:
 *     A standard Tcl result.
 */

int
Gdbtk_Init (interp)
     Tcl_Interp *interp;
{
  Tcl_CreateObjCommand (interp, "gdb_cmd", call_wrapper, gdb_cmd, NULL);
  Tcl_CreateObjCommand (interp, "gdb_immediate", call_wrapper,
                        gdb_immediate_command, NULL);
  Tcl_CreateObjCommand (interp, "gdb_loc", call_wrapper, gdb_loc, NULL);
  Tcl_CreateObjCommand (interp, "gdb_path_conv", call_wrapper, gdb_path_conv, NULL);
  Tcl_CreateObjCommand (interp, "gdb_listfiles", call_wrapper, gdb_listfiles, NULL);
  Tcl_CreateObjCommand (interp, "gdb_listfuncs", call_wrapper, gdb_listfuncs,
                        NULL);
  Tcl_CreateObjCommand (interp, "gdb_get_mem", call_wrapper, gdb_get_mem,
                        NULL);
  Tcl_CreateObjCommand (interp, "gdb_stop", call_wrapper, gdb_stop, NULL);
  Tcl_CreateObjCommand (interp, "gdb_regnames", call_wrapper, gdb_regnames, NULL);
  Tcl_CreateObjCommand (interp, "gdb_fetch_registers", call_wrapper,
                        gdb_fetch_registers, NULL);
  Tcl_CreateObjCommand (interp, "gdb_changed_register_list", call_wrapper,
                        gdb_changed_register_list, NULL);
  Tcl_CreateObjCommand (interp, "gdb_disassemble", call_wrapper,
                        gdb_disassemble, NULL);
  Tcl_CreateObjCommand (interp, "gdb_eval", call_wrapper, gdb_eval, NULL);
  Tcl_CreateObjCommand (interp, "gdb_get_breakpoint_list", call_wrapper,
                        gdb_get_breakpoint_list, NULL);
  Tcl_CreateObjCommand (interp, "gdb_get_breakpoint_info", call_wrapper,
                        gdb_get_breakpoint_info, NULL);
  Tcl_CreateObjCommand (interp, "gdb_clear_file", call_wrapper,
                        gdb_clear_file, NULL);
  Tcl_CreateObjCommand (interp, "gdb_confirm_quit", call_wrapper,
                        gdb_confirm_quit, NULL);
  Tcl_CreateObjCommand (interp, "gdb_force_quit", call_wrapper,
                        gdb_force_quit, NULL);
  Tcl_CreateObjCommand (interp, "gdb_target_has_execution",
                        call_wrapper,
                        gdb_target_has_execution_command, NULL);
  Tcl_CreateObjCommand (interp, "gdb_is_tracing",
                        call_wrapper, gdb_trace_status,
                        NULL);
  Tcl_CreateObjCommand (interp, "gdb_load_info", call_wrapper, gdb_load_info, NULL);
  Tcl_CreateObjCommand (interp, "gdb_get_locals", call_wrapper, gdb_get_locals_command, 
                        NULL);
  Tcl_CreateObjCommand (interp, "gdb_get_args", call_wrapper, gdb_get_args_command,
                         NULL);
  Tcl_CreateObjCommand (interp, "gdb_get_function", call_wrapper, gdb_get_function_command,
                         NULL);
  Tcl_CreateObjCommand (interp, "gdb_get_line", call_wrapper, gdb_get_line_command,
                         NULL);
  Tcl_CreateObjCommand (interp, "gdb_get_file", call_wrapper, gdb_get_file_command,
                         NULL);
  Tcl_CreateObjCommand (interp, "gdb_tracepoint_exists",
                        call_wrapper, gdb_tracepoint_exists_command,  NULL);
  Tcl_CreateObjCommand (interp, "gdb_get_tracepoint_info",
                        call_wrapper, gdb_get_tracepoint_info,  NULL);
  Tcl_CreateObjCommand (interp, "gdb_actions",
                        call_wrapper, gdb_actions_command,  NULL);
  Tcl_CreateObjCommand (interp, "gdb_prompt",
                        call_wrapper, gdb_prompt_command,  NULL);
  Tcl_CreateObjCommand (interp, "gdb_find_file",
                        call_wrapper, gdb_find_file_command,  NULL);
  Tcl_CreateObjCommand (interp, "gdb_get_tracepoint_list",
                        call_wrapper, gdb_get_tracepoint_list,  NULL);  
  Tcl_CreateObjCommand (interp, "gdb_pc_reg", call_wrapper, get_pc_register, NULL);
  Tcl_CreateObjCommand (interp, "gdb_loadfile", call_wrapper, gdb_loadfile,  NULL);
  Tcl_CreateObjCommand (gdbtk_interp, "gdb_search", call_wrapper,
                        gdb_search,  NULL);
  Tcl_CreateObjCommand (interp, "gdb_set_bp", call_wrapper, gdb_set_bp,  NULL);
  Tcl_CreateObjCommand (interp, "gdb_set_bp_addr", call_wrapper, gdb_set_bp_addr,  NULL);
  Tcl_CreateObjCommand (interp, "gdb_find_bp_at_line", call_wrapper, gdb_find_bp_at_line,  NULL);
  Tcl_CreateObjCommand (interp, "gdb_find_bp_at_addr", call_wrapper, gdb_find_bp_at_addr,  NULL);
  Tcl_CreateObjCommand (interp, "gdb_get_trace_frame_num",
                        call_wrapper, gdb_get_trace_frame_num,  NULL);  
  Tcl_CreateObjCommand (interp, "gdb_stack", call_wrapper, gdb_stack, NULL);

  Tcl_LinkVar (interp, "gdb_selected_frame_level",
               (char *) &selected_frame_level,
               TCL_LINK_INT | TCL_LINK_READ_ONLY);

  /* gdb_context is used for debugging multiple threads or tasks */
  Tcl_LinkVar (interp, "gdb_context_id",
               (char *) &gdb_context,
               TCL_LINK_INT | TCL_LINK_READ_ONLY);

  /* Init variable interface...*/
  if (gdb_variable_init (interp) != TCL_OK)
    return TCL_ERROR;
  
  /* Determine where to disassemble from */
  Tcl_LinkVar (gdbtk_interp, "disassemble-from-exec", (char *) &disassemble_from_exec,
               TCL_LINK_INT);

  Tcl_PkgProvide(interp, "Gdbtk", GDBTK_VERSION);
  return TCL_OK;
}

/* This routine acts as a top-level for all GDB code called by Tcl/Tk.  It
   handles cleanups, and uses catch_errors to trap calls to return_to_top_level
   (usually via error).
   This is necessary in order to prevent a longjmp out of the bowels of Tk,
   possibly leaving things in a bad state.  Since this routine can be called
   recursively, it needs to save and restore the contents of the result_ptr as
   necessary. */

int
call_wrapper (clientData, interp, objc, objv)
     ClientData clientData;
     Tcl_Interp *interp;
     int objc;
     Tcl_Obj *CONST objv[];
{
  struct wrapped_call_args wrapped_args;
  gdbtk_result new_result, *old_result_ptr;
  
  old_result_ptr = result_ptr;
  result_ptr = &new_result;
  result_ptr->obj_ptr = Tcl_NewObj();
  result_ptr->flags = GDBTK_TO_RESULT;

  wrapped_args.func = (Tcl_ObjCmdProc *) clientData;
  wrapped_args.interp = interp;
  wrapped_args.objc = objc;
  wrapped_args.objv = objv;
  wrapped_args.val = TCL_OK;

  if (!catch_errors (wrapped_call, &wrapped_args, "", RETURN_MASK_ALL))
    {
      
      wrapped_args.val = TCL_ERROR;     /* Flag an error for TCL */

      /* Make sure the timer interrupts are turned off.  */

      gdbtk_stop_timer ();

      gdb_flush (gdb_stderr);   /* Flush error output */
      gdb_flush (gdb_stdout);   /* Sometimes error output comes here as well */

      /* If we errored out here, and the results were going to the
         console, then gdbtk_fputs will have gathered the result into the
         result_ptr.  We also need to echo them out to the console here */

      gdb_flush (gdb_stderr);   /* Flush error output */
      gdb_flush (gdb_stdout);   /* Sometimes error output comes here as well */

      /* In case of an error, we may need to force the GUI into idle
         mode because gdbtk_call_command may have bombed out while in
         the command routine.  */

      running_now = 0;
      Tcl_Eval (interp, "gdbtk_tcl_idle");
      
    }
  
  /* do not suppress any errors -- a remote target could have errored */
  load_in_progress = 0;

  /*
   * Now copy the result over to the true Tcl result.  If GDBTK_TO_RESULT flag
   * bit is set , this just copies a null object over to the Tcl result, which is
   * fine because we should reset the result in this case anyway.
   */
  if (result_ptr->flags & GDBTK_IN_TCL_RESULT)
    {
      Tcl_DecrRefCount(result_ptr->obj_ptr);
    }
  else
    {
      Tcl_SetObjResult (interp, result_ptr->obj_ptr);
    }

  result_ptr = old_result_ptr;

#ifdef _WIN32
  close_bfds ();
#endif

  return wrapped_args.val;
}

/*
 * This is the wrapper that is passed to catch_errors.
 */

static int
wrapped_call (opaque_args)
     char *opaque_args;
{
  struct wrapped_call_args *args = (struct wrapped_call_args *) opaque_args;
  args->val = (*args->func) (args->func, args->interp, args->objc, args->objv);
  return 1;
}

/* This is a convenience function to sprintf something(s) into a
 * new element in a Tcl list object.
 */

static void
#ifdef ANSI_PROTOTYPES
sprintf_append_element_to_obj (Tcl_Obj *objp, char *format, ...)
#else
sprintf_append_element_to_obj (va_alist)
     va_dcl
#endif
{
  va_list args;
  char buf[1024];
  
#ifdef ANSI_PROTOTYPES
  va_start (args, format);
#else
  Tcl_Obj *objp;
  char *format;

  va_start (args);
  dsp = va_arg (args, Tcl_Obj *);
  format = va_arg (args, char *);
#endif

  vsprintf (buf, format, args);

  Tcl_ListObjAppendElement (NULL, objp, Tcl_NewStringObj (buf, -1));
}
\f
/*
 * This section contains the commands that control execution.
 */

/* This implements the tcl command gdb_clear_file.
 *
 * Prepare to accept a new executable file.  This is called when we
 * want to clear away everything we know about the old file, without
 * asking the user.  The Tcl code will have already asked the user if
 * necessary.  After this is called, we should be able to run the
 * `file' command without getting any questions.  
 *
 * Arguments:
 *    None
 * Tcl Result:
 *    None
 */

static int
gdb_clear_file (clientData, interp, objc, objv)
     ClientData clientData;
     Tcl_Interp *interp;
     int objc;
     Tcl_Obj *CONST objv[];
{
  if (objc != 1)
    Tcl_SetStringObj (result_ptr->obj_ptr,
                      "Wrong number of args, none are allowed.", -1);
  
  if (inferior_pid != 0 && target_has_execution)
    {
      if (attach_flag)
        target_detach (NULL, 0);
      else
        target_kill ();
    }

  if (target_has_execution)
    pop_target ();

  symbol_file_command (NULL, 0);

  /* gdb_loc refers to stop_pc, but nothing seems to clear it, so we
     clear it here.  FIXME: This seems like an abstraction violation
     somewhere.  */
  stop_pc = 0;

  return TCL_OK;
}

/* This implements the tcl command gdb_confirm_quit
 * Ask the user to confirm an exit request.
 *
 * Arguments:
 *    None
 * Tcl Result:
 *    A boolean, 1 if the user answered yes, 0 if no.
 */

static int
gdb_confirm_quit (clientData, interp, objc, objv)
     ClientData clientData;
     Tcl_Interp *interp;
     int objc;
     Tcl_Obj *CONST objv[];
{
  int ret;

  if (objc != 1)
    {
      Tcl_SetStringObj (result_ptr->obj_ptr, "Wrong number of args, should be none.", -1);
      return TCL_ERROR;
    }
  
  ret = quit_confirm ();
  Tcl_SetBooleanObj (result_ptr->obj_ptr, ret);
  return TCL_OK;
}

/* This implements the tcl command gdb_force_quit
 * Quit without asking for confirmation.
 *
 * Arguments:
 *    None
 * Tcl Result:
 *    None
 */

static int
gdb_force_quit (clientData, interp, objc, objv)
     ClientData clientData;
     Tcl_Interp *interp;
     int objc;
     Tcl_Obj *CONST objv[];
{
  if (objc != 1)
    {
      Tcl_SetStringObj (result_ptr->obj_ptr, "Wrong number of args, should be none.", -1);
      return TCL_ERROR;
    }
  
  quit_force ((char *) NULL, 1);
  return TCL_OK;
}

/* This implements the tcl command gdb_stop
 * It stops the target in a continuable fashion.
 *
 * Arguments:
 *    None
 * Tcl Result:
 *    None
 */

static int
gdb_stop (clientData, interp, objc, objv)
     ClientData clientData;
     Tcl_Interp *interp;
     int objc;
     Tcl_Obj *CONST objv[];
{
  if (target_stop != target_ignore)
      target_stop ();
  else
    quit_flag = 1; /* hope something sees this */

  return TCL_OK;
}

\f
/*
 * This section contains Tcl commands that are wrappers for invoking
 * the GDB command interpreter.
 */


/* This implements the tcl command `gdb_eval'.
 * It uses the gdb evaluator to return the value of
 * an expression in the current language
 *
 * Tcl Arguments:
 *     expression - the expression to evaluate.
 * Tcl Result:
 *     The result of the evaluation.
 */

static int
gdb_eval (clientData, interp, objc, objv)
     ClientData clientData;
     Tcl_Interp *interp;
     int objc;
     Tcl_Obj *CONST objv[];
{
  struct expression *expr;
  struct cleanup *old_chain=NULL;
  value_ptr val;

  if (objc != 2)
    {
      Tcl_SetStringObj (result_ptr->obj_ptr,
                        "wrong # args, should be \"gdb_eval expression\"", -1);
      return TCL_ERROR;
    }

  expr = parse_expression (Tcl_GetStringFromObj (objv[1], NULL));

  old_chain = make_cleanup ((make_cleanup_func) free_current_contents, &expr);

  val = evaluate_expression (expr);

  /*
   * Print the result of the expression evaluation.  This will go to
   * eventually go to gdbtk_fputs, and from there be collected into
   * the Tcl result.
   */
  
  val_print (VALUE_TYPE (val), VALUE_CONTENTS (val),
             VALUE_EMBEDDED_OFFSET(val), VALUE_ADDRESS (val),
             gdb_stdout, 0, 0, 0, 0);

  do_cleanups (old_chain);

  return TCL_OK;
}

/* This implements the tcl command "gdb_cmd".
 *  
 * It sends its argument to the GDB command scanner for execution. 
 * This command will never cause the update, idle and busy hooks to be called
 * within the GUI.
 * 
 * Tcl Arguments:
 *    command - The GDB command to execute
 *    from_tty - 1 indicates this comes to the console.  Pass this to the gdb command.
 * Tcl Result:
 *    The output from the gdb command (except for the "load" & "while"
 *    which dump their output to the console.
 */

static int
gdb_cmd (clientData, interp, objc, objv)
     ClientData clientData;
     Tcl_Interp *interp;
     int objc;
     Tcl_Obj *CONST objv[];
{
  int from_tty = 0;
  
  if (objc < 2)
    {
      Tcl_SetStringObj (result_ptr->obj_ptr, "wrong # args", -1);
      return TCL_ERROR;
    }

  if (objc == 3)
    {
      if (Tcl_GetBooleanFromObj (NULL, objv[2], &from_tty) != TCL_OK) {
        Tcl_SetStringObj (result_ptr->obj_ptr, "from_tty must be a boolean.",
                          -1);
        return TCL_ERROR;
      }
    }

  if (running_now || load_in_progress)
    return TCL_OK;

  No_Update = 1;

  /* for the load instruction (and possibly others later) we
     set turn off the GDBTK_TO_RESULT flag bit so gdbtk_fputs() 
     will not buffer all the data until the command is finished. */

  if ((strncmp ("load ", Tcl_GetStringFromObj (objv[1], NULL), 5) == 0))
    {
      result_ptr->flags &= ~GDBTK_TO_RESULT;
      load_in_progress = 1;
    }

  execute_command (Tcl_GetStringFromObj (objv[1], NULL), from_tty);

  if (load_in_progress)
    {
      load_in_progress = 0;
      result_ptr->flags |= GDBTK_TO_RESULT;
    }

  bpstat_do_actions (&stop_bpstat);
  
  return TCL_OK;
}

/*
 * This implements the tcl command "gdb_immediate"
 *  
 * It does exactly the same thing as gdb_cmd, except NONE of its outut 
 * is buffered.  This will also ALWAYS cause the busy, update, and idle hooks to
 * be called, contrasted with gdb_cmd, which NEVER calls them.
 * It turns off the GDBTK_TO_RESULT flag, which diverts the result
 * to the console window.
 *
 * Tcl Arguments:
 *    command - The GDB command to execute
 *    from_tty - 1 to indicate this is from the console.
 * Tcl Result:
 *    None.
 */

static int
gdb_immediate_command (clientData, interp, objc, objv)
     ClientData clientData;
     Tcl_Interp *interp;
     int objc;
     Tcl_Obj *CONST objv[];
{

  int from_tty = 0;
  
  if (objc < 2)
    {
      Tcl_SetStringObj (result_ptr->obj_ptr, "wrong # args", -1);
      return TCL_ERROR;
    }

  if (objc == 3)
    {
      if (Tcl_GetBooleanFromObj (NULL, objv[2], &from_tty) != TCL_OK) {
        Tcl_SetStringObj (result_ptr->obj_ptr, "from_tty must be a boolean.",
                          -1);
        return TCL_ERROR;
      }
    }

  if (running_now || load_in_progress)
    return TCL_OK;

  No_Update = 0;

  result_ptr->flags &= ~GDBTK_TO_RESULT;  

  execute_command (Tcl_GetStringFromObj (objv[1], NULL), from_tty);

  bpstat_do_actions (&stop_bpstat);
  
  result_ptr->flags |= GDBTK_TO_RESULT;

  return TCL_OK;
}

/* This implements the tcl command "gdb_prompt"
 *
 * It returns the gdb interpreter's prompt.
 *
 * Tcl Arguments:
 *    None.
 * Tcl Result:
 *    The prompt.
 */

static int
gdb_prompt_command (clientData, interp, objc, objv)
  ClientData clientData;
  Tcl_Interp *interp;
  int objc;
  Tcl_Obj *CONST objv[];
{
  Tcl_SetStringObj (result_ptr->obj_ptr, get_prompt (), -1);
  return TCL_OK;
}

\f
/*
 * This section contains general informational commands.
 */

/* This implements the tcl command "gdb_target_has_execution"
 *
 * Tells whether the target is executing.
 *
 * Tcl Arguments:
 *    None
 * Tcl Result:
 *    A boolean indicating whether the target is executing.
 */

static int
gdb_target_has_execution_command (clientData, interp, objc, objv)
     ClientData clientData;
     Tcl_Interp *interp;
     int objc;
     Tcl_Obj *CONST objv[];
{
  int result = 0;

  if (target_has_execution && inferior_pid != 0)
    result = 1;

  Tcl_SetBooleanObj (result_ptr->obj_ptr, result);
  return TCL_OK;
}

/* This implements the tcl command "gdb_load_info"
 *
 * It returns information about the file about to be downloaded.
 *
 * Tcl Arguments:
 *    filename: The file to open & get the info on.
 * Tcl Result:
 *    A list consisting of the name and size of each section.
 */

static int
gdb_load_info (clientData, interp, objc, objv)
     ClientData clientData;
     Tcl_Interp *interp;
     int objc;
     Tcl_Obj *CONST objv[];
{
   bfd *loadfile_bfd;
   struct cleanup *old_cleanups;
   asection *s;
   Tcl_Obj *ob[2];

   char *filename = Tcl_GetStringFromObj (objv[1], NULL);

   loadfile_bfd = bfd_openr (filename, gnutarget);
   if (loadfile_bfd == NULL)
     {
       Tcl_SetStringObj (result_ptr->obj_ptr, "Open failed", -1);
       return TCL_ERROR;
     }
   old_cleanups = make_cleanup ((make_cleanup_func) bfd_close, loadfile_bfd);
   
   if (!bfd_check_format (loadfile_bfd, bfd_object)) 
     {
       Tcl_SetStringObj (result_ptr->obj_ptr, "Bad Object File", -1);
       return TCL_ERROR;
    }

   Tcl_SetListObj (result_ptr->obj_ptr, 0, NULL);
   
   for (s = loadfile_bfd->sections; s; s = s->next) 
     {
       if (s->flags & SEC_LOAD) 
         {
           bfd_size_type size = bfd_get_section_size_before_reloc (s);
           if (size > 0)
             {
               ob[0] = Tcl_NewStringObj ((char *) bfd_get_section_name (loadfile_bfd, s), -1);
               ob[1] = Tcl_NewLongObj ((long) size);
               Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr, Tcl_NewListObj (2, ob));
             }
         }
     }
   
   do_cleanups (old_cleanups);
   return TCL_OK;
}


/* gdb_get_locals -
 * This and gdb_get_locals just call gdb_get_vars_command with the right
 * value of clientData.  We can't use the client data in the definition
 * of the command, because the call wrapper uses this instead...
 */

static int
gdb_get_locals_command (clientData, interp, objc, objv)
     ClientData clientData;
     Tcl_Interp *interp;
     int objc;
     Tcl_Obj *CONST objv[];
{

  return gdb_get_vars_command((ClientData) 0, interp, objc, objv);

}

static int
gdb_get_args_command (clientData, interp, objc, objv)
     ClientData clientData;
     Tcl_Interp *interp;
     int objc;
     Tcl_Obj *CONST objv[];
{

  return gdb_get_vars_command((ClientData) 1, interp, objc, objv);

}

/* This implements the tcl commands "gdb_get_locals" and "gdb_get_args"
 *  
 * This function sets the Tcl interpreter's result to a list of variable names
 * depending on clientData. If clientData is one, the result is a list of
 * arguments; zero returns a list of locals -- all relative to the block
 * specified as an argument to the command. Valid commands include
 * anything decode_line_1 can handle (like "main.c:2", "*0x02020202",
 * and "main").
 *
 * Tcl Arguments:
 *   block - the address within which to specify the locals or args.
 * Tcl Result:
 *   A list of the locals or args
 */

static int
gdb_get_vars_command (clientData, interp, objc, objv)
     ClientData clientData;
     Tcl_Interp *interp;
     int objc;
     Tcl_Obj *CONST objv[];
{
  struct symtabs_and_lines sals;
  struct symbol *sym;
  struct block *block;
  char **canonical, *args;
  int i, nsyms, arguments;

  if (objc != 2)
    {
      Tcl_AppendStringsToObj (result_ptr->obj_ptr,
                        "wrong # of args: should be \"",
                        Tcl_GetStringFromObj (objv[0], NULL),
                        " function:line|function|line|*addr\"", NULL);
      return TCL_ERROR;
    }

  arguments = (int) clientData;
  args = Tcl_GetStringFromObj (objv[1], NULL);
  sals = decode_line_1 (&args, 1, NULL, 0, &canonical);
  if (sals.nelts == 0)
    {
      Tcl_SetStringObj (result_ptr->obj_ptr,
                        "error decoding line", -1);
      return TCL_ERROR;
    }

  /* Initialize the result pointer to an empty list. */

  Tcl_SetListObj (result_ptr->obj_ptr, 0, NULL);

  /* Resolve all line numbers to PC's */
  for (i = 0; i < sals.nelts; i++)
    resolve_sal_pc (&sals.sals[i]);
  
  block = block_for_pc (sals.sals[0].pc);
  while (block != 0)
    {
      nsyms = BLOCK_NSYMS (block);
      for (i = 0; i < nsyms; i++)
        {
          sym = BLOCK_SYM (block, i);
          switch (SYMBOL_CLASS (sym)) {
          default:
          case LOC_UNDEF:                 /* catches errors        */
          case LOC_CONST:             /* constant              */
          case LOC_TYPEDEF:           /* local typedef         */
          case LOC_LABEL:             /* local label           */
          case LOC_BLOCK:             /* local function        */
          case LOC_CONST_BYTES:   /* loc. byte seq.        */
          case LOC_UNRESOLVED:    /* unresolved static     */
          case LOC_OPTIMIZED_OUT: /* optimized out         */
            break;
          case LOC_ARG:               /* argument              */
          case LOC_REF_ARG:           /* reference arg         */
          case LOC_REGPARM:           /* register arg          */
          case LOC_REGPARM_ADDR:  /* indirect register arg */
          case LOC_LOCAL_ARG:     /* stack arg             */
          case LOC_BASEREG_ARG:   /* basereg arg           */
            if (arguments)
              Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr,
                                        Tcl_NewStringObj (SYMBOL_NAME (sym), -1));
            break;
          case LOC_LOCAL:             /* stack local           */
          case LOC_BASEREG:           /* basereg local         */
          case LOC_STATIC:            /* static                */
          case LOC_REGISTER:      /* register              */
            if (!arguments)
              Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr,
                                        Tcl_NewStringObj (SYMBOL_NAME (sym), -1));
            break;
          }
        }
      if (BLOCK_FUNCTION (block))
        break;
      else
        block = BLOCK_SUPERBLOCK (block);
    }
  
  return TCL_OK;
}

/* This implements the tcl command "gdb_get_line"
 *
 * It returns the linenumber for a given linespec.  It will take any spec
 * that can be passed to decode_line_1
 *
 * Tcl Arguments:
 *    linespec - the line specification
 * Tcl Result:
 *    The line number for that spec.
 */
static int
gdb_get_line_command (clientData, interp, objc, objv)
     ClientData clientData;
     Tcl_Interp *interp;
     int objc;
     Tcl_Obj *CONST objv[];
{
  struct symtabs_and_lines sals;
  char *args, **canonical;
  
  if (objc != 2)
    {
      Tcl_AppendStringsToObj (result_ptr->obj_ptr, "wrong # of args: should be \"",
                        Tcl_GetStringFromObj (objv[0], NULL),
                        " linespec\"", NULL);
      return TCL_ERROR;
    }

  args = Tcl_GetStringFromObj (objv[1], NULL);
  sals = decode_line_1 (&args, 1, NULL, 0, &canonical);  
  if (sals.nelts == 1)
    {
      Tcl_SetIntObj (result_ptr->obj_ptr, sals.sals[0].line);
      return TCL_OK;
    }

  Tcl_SetStringObj (result_ptr->obj_ptr, "N/A", -1);
  return TCL_OK;
  
}

/* This implements the tcl command "gdb_get_file"
 *
 * It returns the file containing a given line spec.
 *
 * Tcl Arguments:
 *    linespec - The linespec to look up
 * Tcl Result:
 *    The file containing it.
 */

static int
gdb_get_file_command (clientData, interp, objc, objv)
     ClientData clientData;
     Tcl_Interp *interp;
     int objc;
     Tcl_Obj *CONST objv[];
{
  struct symtabs_and_lines sals;
  char *args, **canonical;
  
  if (objc != 2)
    {
      Tcl_AppendStringsToObj (result_ptr->obj_ptr, "wrong # of args: should be \"",
                        Tcl_GetStringFromObj (objv[0], NULL),
                        " linespec\"", NULL);
      return TCL_ERROR;
    }

  args = Tcl_GetStringFromObj (objv[1], NULL);
  sals = decode_line_1 (&args, 1, NULL, 0, &canonical);  
  if (sals.nelts == 1)
    {
      Tcl_SetStringObj (result_ptr->obj_ptr, sals.sals[0].symtab->filename, -1);
      return TCL_OK;
    }

  Tcl_SetStringObj (result_ptr->obj_ptr, "N/A", -1);
  return TCL_OK;
}

/* This implements the tcl command "gdb_get_function"
 *
 * It finds the function containing the given line spec.
 *
 * Tcl Arguments:
 *    linespec - The line specification
 * Tcl Result:
 *    The function that contains it, or "N/A" if it is not in a function.
 */
static int
gdb_get_function_command (clientData, interp, objc, objv)
     ClientData clientData;
     Tcl_Interp *interp;
     int objc;
     Tcl_Obj *CONST objv[];
{
  char *function;
  struct symtabs_and_lines sals;
  char *args, **canonical;

  if (objc != 2)
    {
      Tcl_AppendStringsToObj (result_ptr->obj_ptr, "wrong # of args: should be \"",
                        Tcl_GetStringFromObj (objv[0], NULL),
                        " linespec\"", NULL);
      return TCL_ERROR;
    }

  args = Tcl_GetStringFromObj (objv[1], NULL);
  sals = decode_line_1 (&args, 1, NULL, 0, &canonical);  
  if (sals.nelts == 1)
    {
      resolve_sal_pc (&sals.sals[0]);
      find_pc_partial_function (sals.sals[0].pc, &function, NULL, NULL);
      if (function != NULL)
        {
          Tcl_SetStringObj (result_ptr->obj_ptr, function, -1);
          return TCL_OK;
        }
    }
  
  Tcl_SetStringObj (result_ptr->obj_ptr, "N/A", -1);
  return TCL_OK;
}

/* This implements the tcl command "gdb_find_file"
 *
 * It searches the symbol tables to get the full pathname to a file.
 *
 * Tcl Arguments:
 *    filename: the file name to search for.
 * Tcl Result:
 *    The full path to the file, or an empty string if the file is not
 *    found.
 */

static int
gdb_find_file_command (clientData, interp, objc, objv)
  ClientData clientData;
  Tcl_Interp *interp;
  int objc;
  Tcl_Obj *CONST objv[];
{
  char *filename = NULL;
  struct symtab *st;

  if (objc != 2)
    {
      Tcl_WrongNumArgs(interp, 1, objv, "filename");
      return TCL_ERROR;
    }

  st = full_lookup_symtab (Tcl_GetStringFromObj (objv[1], NULL));
  if (st)
    filename = st->fullname;

  if (filename == NULL)
    Tcl_SetStringObj (result_ptr->obj_ptr, "", 0);
  else
    Tcl_SetStringObj (result_ptr->obj_ptr, filename, -1);

  return TCL_OK;
}

/* This implements the tcl command "gdb_listfiles"
 *
 * This lists all the files in the current executible.
 *
 * Note that this currently pulls in all sorts of filenames
 * that aren't really part of the executable.  It would be
 * best if we could check each file to see if it actually
 * contains executable lines of code, but we can't do that
 * with psymtabs.
 *
 * Arguments:
 *    ?pathname? - If provided, only files which match pathname
 *        (up to strlen(pathname)) are included. THIS DOES NOT
 *        CURRENTLY WORK BECAUSE PARTIAL_SYMTABS DON'T SUPPLY
 *        THE FULL PATHNAME!!!
 *
 * Tcl Result:
 *    A list of all matching files.
 */
static int
gdb_listfiles (clientData, interp, objc, objv)
  ClientData clientData;
  Tcl_Interp *interp;
  int objc;
  Tcl_Obj *CONST objv[];
{
  struct objfile *objfile;
  struct partial_symtab *psymtab;
  struct symtab *symtab;
  char *lastfile, *pathname=NULL, **files;
  int files_size;
  int i, numfiles = 0, len = 0;
  
  files_size = 1000;
  files = (char **) xmalloc (sizeof (char *) * files_size);
  
  if (objc > 2)
    {
      Tcl_WrongNumArgs (interp, 1, objv, "Usage: gdb_listfiles ?pathname?");
      return TCL_ERROR;
    }
  else if (objc == 2)
    pathname = Tcl_GetStringFromObj (objv[1], &len);

  ALL_PSYMTABS (objfile, psymtab)
    {
      if (numfiles == files_size)
        {
          files_size = files_size * 2;
          files = (char **) xrealloc (files, sizeof (char *) * files_size);
        }
      if (psymtab->filename)
        {
          if (!len || !strncmp(pathname, psymtab->filename,len)
              || !strcmp(psymtab->filename, basename(psymtab->filename)))
            {
              files[numfiles++] = basename(psymtab->filename);
            }
        }
    }

  ALL_SYMTABS (objfile, symtab)
    {
      if (numfiles == files_size)
        {
          files_size = files_size * 2;
          files = (char **) xrealloc (files, sizeof (char *) * files_size);
        }
      if (symtab->filename && symtab->linetable && symtab->linetable->nitems)
        {
          if (!len || !strncmp(pathname, symtab->filename,len)
              || !strcmp(symtab->filename, basename(symtab->filename)))
            {
              files[numfiles++] = basename(symtab->filename);
            }
        }
    }

  qsort (files, numfiles, sizeof(char *), comp_files);

  lastfile = "";

  /* Discard the old result pointer, in case it has accumulated anything
     and set it to a new list object */
  
  Tcl_SetListObj(result_ptr->obj_ptr, 0, NULL);
  
  for (i = 0; i < numfiles; i++)
    {
      if (strcmp(files[i],lastfile))
        Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr, Tcl_NewStringObj(files[i], -1));
      lastfile = files[i];
    }

  free (files);
  return TCL_OK;
}

static int
comp_files (file1, file2)
     const void *file1, *file2;
{
  return strcmp(* (char **) file1, * (char **) file2);
}


/* This implements the tcl command "gdb_search"
 *
 *
 * Tcl Arguments:
 *    option - One of "functions", "variables" or "types"
 *    regexp - The regular expression to look for.
 * Then, optionally:
 *    -files fileList
 *    -static 1/0
 * Tcl Result:
 *
 */

static int
gdb_search (clientData, interp, objc, objv)
     ClientData clientData;
     Tcl_Interp *interp;
     int objc;
     Tcl_Obj *CONST objv[];
{
  struct symbol_search *ss = NULL;
  struct symbol_search *p;
  struct cleanup *old_chain = NULL;
  Tcl_Obj *CONST *switch_objv;
  int index, switch_objc, i;
  namespace_enum space = 0;
  char *regexp;
  int static_only, nfiles;
  Tcl_Obj **file_list;
  char **files;
  static char *search_options[] = { "functions", "variables", "types", (char *) NULL };
  static char *switches[] = { "-files", "-static", (char *) NULL };
  enum search_opts { SEARCH_FUNCTIONS, SEARCH_VARIABLES, SEARCH_TYPES };
  enum switches_opts { SWITCH_FILES, SWITCH_STATIC_ONLY };

  if (objc < 3)
    {
      Tcl_WrongNumArgs (interp, 1, objv, "option regexp ?arg ...?");
          result_ptr->flags |= GDBTK_IN_TCL_RESULT;
      return TCL_ERROR;
    }

  if (Tcl_GetIndexFromObj (interp, objv[1], search_options, "option", 0,
                           &index) != TCL_OK)
    {
      result_ptr->flags |= GDBTK_IN_TCL_RESULT;
      return TCL_ERROR;
    }

  /* Unfortunately, we cannot teach search_symbols to search on
     multiple regexps, so we have to do a two-tier search for
     any searches which choose to narrow the playing field. */
  switch ((enum search_opts) index)
    {
    case SEARCH_FUNCTIONS:
      space = FUNCTIONS_NAMESPACE;      break;
    case SEARCH_VARIABLES:
      space = VARIABLES_NAMESPACE;      break;
    case SEARCH_TYPES:
      space = TYPES_NAMESPACE;          break;
    }

  regexp = Tcl_GetStringFromObj (objv[2], NULL);
  /* Process any switches that refine the search */
  switch_objc = objc - 3;
  switch_objv = objv + 3;

  static_only = 0;
  nfiles = 0;
  files = (char **) NULL;
  while (switch_objc > 0)
    {
      if (Tcl_GetIndexFromObj (interp, switch_objv[0], switches,
                               "option", 0, &index) != TCL_OK)
        {
          result_ptr->flags |= GDBTK_IN_TCL_RESULT;
          return TCL_ERROR;
        }

      switch ((enum switches_opts) index)
        {
        case SWITCH_FILES:
          {
            int result;
            if (switch_objc < 2)
              {
                Tcl_WrongNumArgs (interp, 2, objv, "[-files fileList -static 1|0]");
                result_ptr->flags |= GDBTK_IN_TCL_RESULT;
                return TCL_ERROR;
              }
            result = Tcl_ListObjGetElements (interp, switch_objv[1], &nfiles, &file_list);
            if (result != TCL_OK)
              return result;

            files = (char **) xmalloc (nfiles * sizeof (char *));
            for (i = 0; i < nfiles; i++)
              files[i] = Tcl_GetStringFromObj (file_list[i], NULL);
            switch_objc--;
            switch_objv++;
          }
          break;
        case SWITCH_STATIC_ONLY:
          if (switch_objc < 2)
            {
              Tcl_WrongNumArgs (interp, 2, objv, "[-files fileList] [-static 1|0]");
              result_ptr->flags |= GDBTK_IN_TCL_RESULT;
              return TCL_ERROR;
            }              
          if ( Tcl_GetBooleanFromObj (interp, switch_objv[1], &static_only) !=
               TCL_OK) {
            result_ptr->flags |= GDBTK_IN_TCL_RESULT;
            return TCL_ERROR;
          }
          switch_objc--;
          switch_objv++;
        }
      switch_objc--;
      switch_objv++;
    }

  search_symbols (regexp, space, nfiles, files, &ss);
  if (ss != NULL)
    old_chain = make_cleanup ((make_cleanup_func) free_search_symbols, ss);

  Tcl_SetListObj(result_ptr->obj_ptr, 0, NULL);  

  for (p = ss; p != NULL; p = p->next)
    {
      Tcl_Obj *elem;

      if (static_only && p->block != STATIC_BLOCK)
        continue;

      /* Strip off some C++ special symbols, like RTTI and global
         constructors/destructors. */
      if ((p->symbol != NULL && !STREQN (SYMBOL_NAME (p->symbol), "__tf", 4)
           && !STREQN (SYMBOL_NAME (p->symbol), "_GLOBAL_", 8))
          || p->msymbol != NULL)
        {
          elem = Tcl_NewListObj (0, NULL);

          if (p->msymbol == NULL)
            Tcl_ListObjAppendElement (interp, elem, 
                                      Tcl_NewStringObj (SYMBOL_SOURCE_NAME (p->symbol), -1));
          else
            Tcl_ListObjAppendElement (interp, elem,
                                      Tcl_NewStringObj (SYMBOL_SOURCE_NAME (p->msymbol), -1));

          Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr, elem);
        }
    }
  
  if (ss != NULL)
    do_cleanups (old_chain);

  return TCL_OK;
}

/* This implements the tcl command gdb_listfuncs
 *  
 * It lists all the functions defined in a given file
 * 
 * Arguments:
 *    file - the file to look in
 * Tcl Result:
 *    A list of two element lists, the first element is
 *    the symbol name, and the second is a boolean indicating
 *    whether the symbol is demangled (1 for yes).
 */

static int
gdb_listfuncs (clientData, interp, objc, objv)
     ClientData clientData;
     Tcl_Interp *interp;
     int objc;
     Tcl_Obj *CONST objv[];
{
  struct symtab *symtab;
  struct blockvector *bv;
  struct block *b;
  struct symbol *sym;
  int i,j;
  Tcl_Obj *funcVals[2];

  if (objc != 2)
    {
      Tcl_SetStringObj (result_ptr->obj_ptr, "wrong # args", -1);
    }
  
  symtab = full_lookup_symtab (Tcl_GetStringFromObj (objv[1], NULL));
  if (!symtab)
    {
      Tcl_SetStringObj (result_ptr->obj_ptr, "No such file", -1);
      return TCL_ERROR;
    }

  if (mangled == NULL)
    {
      mangled = Tcl_NewBooleanObj(1);
      not_mangled = Tcl_NewBooleanObj(0);
      Tcl_IncrRefCount(mangled);
      Tcl_IncrRefCount(not_mangled);
    }

  Tcl_SetListObj (result_ptr->obj_ptr, 0, NULL);
  
  bv = BLOCKVECTOR (symtab);
  for (i = GLOBAL_BLOCK; i <= STATIC_BLOCK; i++)
    {
      b = BLOCKVECTOR_BLOCK (bv, i);
      /* Skip the sort if this block is always sorted.  */
      if (!BLOCK_SHOULD_SORT (b))
        sort_block_syms (b);
      for (j = 0; j < BLOCK_NSYMS (b); j++)
        {
          sym = BLOCK_SYM (b, j);
          if (SYMBOL_CLASS (sym) == LOC_BLOCK)
            {
              
              char *name = SYMBOL_DEMANGLED_NAME (sym);

              if (name)
                {
                  /* strip out "global constructors" and "global destructors" */
                  /* because we aren't interested in them. */
                  if (strncmp (name, "global ", 7))
                    {
                      /* If the function is overloaded, print out the functions
                         declaration, not just its name. */
                      
                      funcVals[0] = Tcl_NewStringObj(name, -1);
                      funcVals[1] = mangled;
                    }
                  else
                    continue;

                }
              else
                {
                  funcVals[0] = Tcl_NewStringObj(SYMBOL_NAME(sym), -1);
                  funcVals[1] = not_mangled;
                }
              Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
                                        Tcl_NewListObj (2, funcVals));
            }
        }
    }
  return TCL_OK;
}

\f
/*
 * This section contains all the commands that act on the registers:
 */

/* This is a sort of mapcar function for operations on registers */ 
            
static int
map_arg_registers (objc, objv, func, argp)
     int objc;
     Tcl_Obj *CONST objv[];
     void (*func) PARAMS ((int regnum, void *argp));
     void *argp;
{
  int regnum;

  /* Note that the test for a valid register must include checking the
     REGISTER_NAME because NUM_REGS may be allocated for the union of
     the register sets within a family of related processors.  In this
     case, some entries of REGISTER_NAME will change depending upon
     the particular processor being debugged.  */

  if (objc == 0)                /* No args, just do all the regs */
    {
      for (regnum = 0;
           regnum < NUM_REGS
             && REGISTER_NAME (regnum) != NULL
             && *REGISTER_NAME (regnum) != '\000';
           regnum++)
        func (regnum, argp);

      return TCL_OK;
    }

  /* Else, list of register #s, just do listed regs */
  for (; objc > 0; objc--, objv++)
    {
      if (Tcl_GetIntFromObj (NULL, *objv, &regnum) != TCL_OK)
        {
          result_ptr->flags |= GDBTK_IN_TCL_RESULT;
          return TCL_ERROR;
        }

      if (regnum >= 0
          && regnum < NUM_REGS
          && REGISTER_NAME (regnum) != NULL
          && *REGISTER_NAME (regnum) != '\000')
        func (regnum, argp);
      else
        {
          Tcl_SetStringObj (result_ptr->obj_ptr, "bad register number", -1);
          return TCL_ERROR;
        }
    }

  return TCL_OK;
}
            
/* This implements the TCL command `gdb_regnames', which returns a list of
   all of the register names. */

static int
gdb_regnames (clientData, interp, objc, objv)
     ClientData clientData;
     Tcl_Interp *interp;
     int objc;
     Tcl_Obj *CONST objv[];
{
  objc--;
  objv++;

  return map_arg_registers (objc, objv, get_register_name, NULL);
}

static void
get_register_name (regnum, argp)
     int regnum;
     void *argp;                /* Ignored */
{
  Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
                            Tcl_NewStringObj (REGISTER_NAME (regnum), -1));
}

/* This implements the tcl command gdb_fetch_registers
 * Pass it a list of register names, and it will
 * return their values as a list.
 *
 * Tcl Arguments:
 *    format: The format string for printing the values
 *    args: the registers to look for
 * Tcl Result:
 *    A list of their values.
 */

static int
gdb_fetch_registers (clientData, interp, objc, objv)
     ClientData clientData;
     Tcl_Interp *interp;
     int objc;
     Tcl_Obj *CONST objv[];
{
  int format, result;

  if (objc < 2)
    {
      Tcl_SetStringObj (result_ptr->obj_ptr,
                        "wrong # args, should be gdb_fetch_registers format ?register1 register2 ...?", -1);
    }
  objc -= 2;
  objv++;
  format = *(Tcl_GetStringFromObj(objv[0], NULL));  
  objv++;
  
  
  result_ptr->flags |= GDBTK_MAKES_LIST; /* Output the results as a list */
  result = map_arg_registers (objc, objv, get_register, (void *) format);
  result_ptr->flags &= ~GDBTK_MAKES_LIST;
  
  return result; 
}

static void
get_register (regnum, fp)
     int regnum;
     void *fp;
{
  char raw_buffer[MAX_REGISTER_RAW_SIZE];
  char virtual_buffer[MAX_REGISTER_VIRTUAL_SIZE];
  int format = (int)fp;
  int optim;

  if (format == 'N')
    format = 0;

  /* read_relative_register_raw_bytes returns a virtual frame pointer
     (FRAME_FP (selected_frame)) if regnum == FP_REGNUM instead
     of the real contents of the register. To get around this,
     use get_saved_register instead. */
  get_saved_register (raw_buffer, &optim, (CORE_ADDR *) NULL, selected_frame,
                      regnum, (enum lval_type *) NULL);
  if (optim)
    {
      Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
                                Tcl_NewStringObj ("Optimized out", -1));
      return;
    }

  /* Convert raw data to virtual format if necessary.  */

  if (REGISTER_CONVERTIBLE (regnum))
    {
      REGISTER_CONVERT_TO_VIRTUAL (regnum, REGISTER_VIRTUAL_TYPE (regnum),
                                   raw_buffer, virtual_buffer);
    }
  else
    memcpy (virtual_buffer, raw_buffer, REGISTER_VIRTUAL_SIZE (regnum));

  if (format == 'r')
    {
      int j;
      char *ptr, buf[1024];

      strcpy (buf, "0x");
      ptr = buf + 2;      
      for (j = 0; j < REGISTER_RAW_SIZE (regnum); j++)
        {
          register int idx = TARGET_BYTE_ORDER == BIG_ENDIAN ? j
            : REGISTER_RAW_SIZE (regnum) - 1 - j;
          sprintf(ptr, "%02x", (unsigned char)raw_buffer[idx]);
          ptr += 2;
        }
      fputs_filtered (buf, gdb_stdout);
    }
  else
    val_print (REGISTER_VIRTUAL_TYPE (regnum), virtual_buffer, 0, 0,
               gdb_stdout, format, 1, 0, Val_pretty_default);

}

/* This implements the tcl command get_pc_reg
 * It returns the value of the PC register
 *
 * Tcl Arguments:
 *    None
 * Tcl Result:
 *    The value of the pc register.
 */

static int
get_pc_register (clientData, interp, objc, objv)
  ClientData clientData;
  Tcl_Interp *interp;
  int objc;
  Tcl_Obj *CONST objv[];
{
  char buff[64];
  
  sprintf (buff, "0x%llx",(long long) read_register (PC_REGNUM));
  Tcl_SetStringObj(result_ptr->obj_ptr, buff, -1);
  return TCL_OK;
}

/* This implements the tcl command "gdb_changed_register_list"
 * It takes a list of registers, and returns a list of
 * the registers on that list that have changed since the last
 * time the proc was called.
 *
 * Tcl Arguments:
 *    A list of registers.
 * Tcl Result:
 *    A list of changed registers.
 */

static int
gdb_changed_register_list (clientData, interp, objc, objv)
     ClientData clientData;
     Tcl_Interp *interp;
     int objc;
     Tcl_Obj *CONST objv[];
{
  objc--;
  objv++;

  return map_arg_registers (objc, objv, register_changed_p, NULL);
}

static void
register_changed_p (regnum, argp)
     int regnum;
     void *argp;                /* Ignored */
{
  char raw_buffer[MAX_REGISTER_RAW_SIZE];

  if (read_relative_register_raw_bytes (regnum, raw_buffer))
    return;

  if (memcmp (&old_regs[REGISTER_BYTE (regnum)], raw_buffer,
              REGISTER_RAW_SIZE (regnum)) == 0)
    return;

  /* Found a changed register.  Save new value and return its number. */

  memcpy (&old_regs[REGISTER_BYTE (regnum)], raw_buffer,
          REGISTER_RAW_SIZE (regnum));

  Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr, Tcl_NewIntObj(regnum));
}
\f
/*
 * This section contains the commands that deal with tracepoints:
 */

/* return a list of all tracepoint numbers in interpreter */
static int
gdb_get_tracepoint_list (clientData, interp, objc, objv)
  ClientData clientData;
  Tcl_Interp *interp;
  int objc;
  Tcl_Obj *CONST objv[];
{
  struct tracepoint *tp;

  Tcl_SetListObj (result_ptr->obj_ptr, 0, NULL);

  ALL_TRACEPOINTS (tp)
    Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr, Tcl_NewIntObj (tp->number));

  return TCL_OK;
}

/* returns -1 if not found, tracepoint # if found */
int
tracepoint_exists (char * args)
{
  struct tracepoint *tp;
  char **canonical;
  struct symtabs_and_lines sals;
  char  *file = NULL;
  int    result = -1;

  sals = decode_line_1 (&args, 1, NULL, 0, &canonical);  
  if (sals.nelts == 1)
    {
      resolve_sal_pc (&sals.sals[0]);
      file = xmalloc (strlen (sals.sals[0].symtab->dirname)
                      + strlen (sals.sals[0].symtab->filename) + 1);
      if (file != NULL)
        {
          strcpy (file, sals.sals[0].symtab->dirname);
          strcat (file, sals.sals[0].symtab->filename);

          ALL_TRACEPOINTS (tp)
            {
              if (tp->address == sals.sals[0].pc)
                result = tp->number;
#if 0
              /* Why is this here? This messes up assembly traces */
              else if (tp->source_file != NULL
                       && strcmp (tp->source_file, file) == 0
                       && sals.sals[0].line == tp->line_number)
                result = tp->number;
#endif                
            }
        }
    }
  if (file != NULL)
    free (file);
  return result;
}

static int
gdb_tracepoint_exists_command (clientData, interp, objc, objv)
  ClientData clientData;
  Tcl_Interp *interp;
  int objc;
  Tcl_Obj *CONST objv[];
{
  char * args;

  if (objc != 2)
    {
      Tcl_AppendStringsToObj (result_ptr->obj_ptr, "wrong # of args: should be \"",
                        Tcl_GetStringFromObj (objv[0], NULL),
                        " function:line|function|line|*addr\"", NULL);
      return TCL_ERROR;
    }
  
  args = Tcl_GetStringFromObj (objv[1], NULL);
  
  Tcl_SetIntObj (result_ptr->obj_ptr, tracepoint_exists (args));
  return TCL_OK;
}

static int
gdb_get_tracepoint_info (clientData, interp, objc, objv)
     ClientData clientData;
     Tcl_Interp *interp;
     int objc;
     Tcl_Obj  *CONST objv[];
{
  struct symtab_and_line sal;
  int tpnum;
  struct tracepoint *tp;
  struct action_line *al;
  Tcl_Obj *action_list;
  char *filename, *funcname, *fname;
  char tmp[19];
  
  if (objc != 2)
    {
      Tcl_SetStringObj (result_ptr->obj_ptr, "wrong # args", -1);
      return TCL_ERROR;
    }
  
  if (Tcl_GetIntFromObj (NULL, objv[1], &tpnum) != TCL_OK)
    {
      result_ptr->flags |= GDBTK_IN_TCL_RESULT;
      return TCL_ERROR;
    }

  ALL_TRACEPOINTS (tp)
    if (tp->number == tpnum)
      break;

  if (tp == NULL)
    {
      char buff[64];
      sprintf (buff, "Tracepoint #%d does not exist", tpnum);
      Tcl_SetStringObj (result_ptr->obj_ptr, buff, -1);
      return TCL_ERROR;
    }

  Tcl_SetListObj (result_ptr->obj_ptr, 0, NULL);
  sal = find_pc_line (tp->address, 0);
  filename = symtab_to_filename (sal.symtab);
  if (filename == NULL)
    filename = "N/A";
  Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr,
                            Tcl_NewStringObj (filename, -1));
  
  find_pc_partial_function (tp->address, &funcname, NULL, NULL);
  fname = cplus_demangle (funcname, 0);
  if (fname)
    {
      Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr, Tcl_NewStringObj
                          (fname, -1));
      free (fname);
    }
  else
    Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr, Tcl_NewStringObj
                              (funcname, -1));
  
  Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr, Tcl_NewIntObj (sal.line));
  sprintf (tmp, "0x%lx", tp->address);
  Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr, Tcl_NewStringObj (tmp, -1));
  Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr, Tcl_NewIntObj (tp->enabled));
  Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr, Tcl_NewIntObj (tp->pass_count));
  Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr, Tcl_NewIntObj (tp->step_count));
  Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr, Tcl_NewIntObj (tp->thread));
  Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr, Tcl_NewIntObj (tp->hit_count));

  /* Append a list of actions */
  action_list = Tcl_NewObj ();
  for (al = tp->actions; al != NULL; al = al->next)
    {
      Tcl_ListObjAppendElement (interp, action_list,
                                Tcl_NewStringObj (al->action, -1));
    }
  Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr, action_list);

  return TCL_OK;
}


static int
gdb_trace_status (clientData, interp, objc, objv)
     ClientData clientData;
     Tcl_Interp *interp;
     int objc;
     Tcl_Obj *CONST objv[];
{
  int result = 0;
 
  if (trace_running_p)
    result = 1;
 
  Tcl_SetIntObj (result_ptr->obj_ptr, result);
  return TCL_OK;
}



static int
gdb_get_trace_frame_num (clientData, interp, objc, objv)
     ClientData clientData;
     Tcl_Interp *interp;
     int objc;
     Tcl_Obj *CONST objv[];
{
  if (objc != 1)
    {
      Tcl_AppendStringsToObj (result_ptr->obj_ptr, "wrong # of args: should be \"",
                        Tcl_GetStringFromObj (objv[0], NULL),
                        " linespec\"", NULL);
      return TCL_ERROR;
    }
 
  Tcl_SetIntObj (result_ptr->obj_ptr, get_traceframe_number ());
  return TCL_OK;
  
}
 
/* This implements the tcl command gdb_actions
 * It sets actions for a given tracepoint.
 *
 * Tcl Arguments:
 *    number: the tracepoint in question
 *    actions: the actions to add to this tracepoint
 * Tcl Result:
 *    None.
 */

static int
gdb_actions_command (clientData, interp, objc, objv)
  ClientData clientData;
  Tcl_Interp *interp;
  int objc;
  Tcl_Obj *CONST objv[];
{
  struct tracepoint *tp;
  Tcl_Obj **actions;
  int      nactions, i, len;
  char *number, *args, *action;
  long step_count;
  struct action_line *next = NULL, *temp;
  enum actionline_type linetype;

  if (objc != 3)
    {
      Tcl_AppendStringsToObj (result_ptr->obj_ptr, "wrong # args: should be: \"",
                        Tcl_GetStringFromObj (objv[0], NULL),
                        " number actions\"", NULL);
      return TCL_ERROR;
    }

  args = number = Tcl_GetStringFromObj (objv[1], NULL);
  tp = get_tracepoint_by_number (&args);
  if (tp == NULL)
    {
      Tcl_AppendStringsToObj (result_ptr->obj_ptr, "Tracepoint \"", number, "\" does not exist", NULL);
      return TCL_ERROR;
    }

  /* Free any existing actions */
  if (tp->actions != NULL)
    free_actions (tp);

  step_count = 0;

  Tcl_ListObjGetElements (interp, objv[2], &nactions, &actions);

  /* Add the actions to the tracepoint */
  for (i = 0; i < nactions; i++)
    {
      temp = xmalloc (sizeof (struct action_line));
      temp->next = NULL;
      action = Tcl_GetStringFromObj (actions[i], &len);
      temp->action = savestring (action, len);

      linetype = validate_actionline (&(temp->action), tp);

      if (linetype == BADLINE) 
       {
         free (temp);
         continue;
       }

      if (next == NULL)
        {
          tp->actions = temp;
          next = temp;
        }
      else
        {
          next->next = temp;
          next = temp;
        }
    }
  
  return TCL_OK;
}
\f
/*
 * This section has commands that handle source disassembly.
 */

/* This implements the tcl command gdb_disassemble
 *
 * Arguments:
 *    source_with_assm - must be "source" or "nosource"
 *    low_address - the address from which to start disassembly
 *    ?hi_address? - the address to which to disassemble, defaults
 *                   to the end of the function containing low_address.
 * Tcl Result:
 *    The disassembled code is passed to fputs_unfiltered, so it
 *    either goes to the console if result_ptr->obj_ptr is NULL or to
 *    the Tcl result.
 */

static int
gdb_disassemble (clientData, interp, objc, objv)
     ClientData clientData;
     Tcl_Interp *interp;
     int objc;
     Tcl_Obj *CONST objv[];
{
  CORE_ADDR pc, low, high;
  int mixed_source_and_assembly;
  static disassemble_info di;
  static int di_initialized;
  char *arg_ptr;

  if (objc != 3 && objc != 4)
    error ("wrong # args");

  if (! di_initialized)
    {
      INIT_DISASSEMBLE_INFO_NO_ARCH (di, gdb_stdout,
                                     (fprintf_ftype) fprintf_unfiltered);
      di.flavour = bfd_target_unknown_flavour;
      di.memory_error_func = dis_asm_memory_error;
      di.print_address_func = dis_asm_print_address;
      di_initialized = 1;
    }

  di.mach = TARGET_PRINT_INSN_INFO->mach;
  if (TARGET_BYTE_ORDER == BIG_ENDIAN)
    di.endian = BFD_ENDIAN_BIG;
  else
    di.endian = BFD_ENDIAN_LITTLE;

  arg_ptr = Tcl_GetStringFromObj (objv[1], NULL);
  if (*arg_ptr == 's' && strcmp (arg_ptr, "source") == 0)
    mixed_source_and_assembly = 1;
  else if (*arg_ptr == 'n' && strcmp (arg_ptr, "nosource") == 0)
    mixed_source_and_assembly = 0;
  else
    error ("First arg must be 'source' or 'nosource'");

  low = parse_and_eval_address (Tcl_GetStringFromObj (objv[2], NULL));

  if (objc == 3)
    {
      if (find_pc_partial_function (low, NULL, &low, &high) == 0)
        error ("No function contains specified address");
    }
  else
    high = parse_and_eval_address (Tcl_GetStringFromObj (objv[3], NULL));

  /* If disassemble_from_exec == -1, then we use the following heuristic to
     determine whether or not to do disassembly from target memory or from the
     exec file:

     If we're debugging a local process, read target memory, instead of the
     exec file.  This makes disassembly of functions in shared libs work
     correctly.

     Else, we're debugging a remote process, and should disassemble from the
     exec file for speed.  However, this is no good if the target modifies its
     code (for relocation, or whatever).
   */

  if (disassemble_from_exec == -1)
    {
      if (strcmp (target_shortname, "child") == 0
          || strcmp (target_shortname, "procfs") == 0
          || strcmp (target_shortname, "vxprocess") == 0)
        disassemble_from_exec = 0; /* It's a child process, read inferior mem */
      else
        disassemble_from_exec = 1; /* It's remote, read the exec file */
    }

  if (disassemble_from_exec)
    di.read_memory_func = gdbtk_dis_asm_read_memory;
  else
    di.read_memory_func = dis_asm_read_memory;

  /* If just doing straight assembly, all we need to do is disassemble
     everything between low and high.  If doing mixed source/assembly, we've
     got a totally different path to follow.  */

  if (mixed_source_and_assembly)
    {                           /* Come here for mixed source/assembly */
      /* The idea here is to present a source-O-centric view of a function to
         the user.  This means that things are presented in source order, with
         (possibly) out of order assembly immediately following.  */
      struct symtab *symtab;
      struct linetable_entry *le;
      int nlines;
      int newlines;
      struct my_line_entry *mle;
      struct symtab_and_line sal;
      int i;
      int out_of_order;
      int next_line;

      symtab = find_pc_symtab (low); /* Assume symtab is valid for whole PC range */

      if (!symtab || !symtab->linetable)
        goto assembly_only;

      /* First, convert the linetable to a bunch of my_line_entry's.  */

      le = symtab->linetable->item;
      nlines = symtab->linetable->nitems;

      if (nlines <= 0)
        goto assembly_only;

      mle = (struct my_line_entry *) alloca (nlines * sizeof (struct my_line_entry));

      out_of_order = 0;
      
      /* Copy linetable entries for this function into our data structure, creating
         end_pc's and setting out_of_order as appropriate.  */

      /* First, skip all the preceding functions.  */

      for (i = 0; i < nlines - 1 && le[i].pc < low; i++) ;

      /* Now, copy all entries before the end of this function.  */

      newlines = 0;
      for (; i < nlines - 1 && le[i].pc < high; i++)
        {
          if (le[i].line == le[i + 1].line
              && le[i].pc == le[i + 1].pc)
            continue;           /* Ignore duplicates */

          mle[newlines].line = le[i].line;
          if (le[i].line > le[i + 1].line)
            out_of_order = 1;
          mle[newlines].start_pc = le[i].pc;
          mle[newlines].end_pc = le[i + 1].pc;
          newlines++;
        }

      /* If we're on the last line, and it's part of the function, then we need to
         get the end pc in a special way.  */

      if (i == nlines - 1
          && le[i].pc < high)
        {
          mle[newlines].line = le[i].line;
          mle[newlines].start_pc = le[i].pc;
          sal = find_pc_line (le[i].pc, 0);
          mle[newlines].end_pc = sal.end;
          newlines++;
        }

      /* Now, sort mle by line #s (and, then by addresses within lines). */

      if (out_of_order)
        qsort (mle, newlines, sizeof (struct my_line_entry), compare_lines);

      /* Now, for each line entry, emit the specified lines (unless they have been
         emitted before), followed by the assembly code for that line.  */

      next_line = 0;            /* Force out first line */
      for (i = 0; i < newlines; i++)
        {
          /* Print out everything from next_line to the current line.  */

          if (mle[i].line >= next_line)
            {
              if (next_line != 0)
                print_source_lines (symtab, next_line, mle[i].line + 1, 0);
              else
                print_source_lines (symtab, mle[i].line, mle[i].line + 1, 0);

              next_line = mle[i].line + 1;
            }

          for (pc = mle[i].start_pc; pc < mle[i].end_pc; )
            {
              QUIT;
              fputs_unfiltered ("    ", gdb_stdout);
              print_address (pc, gdb_stdout);
              fputs_unfiltered (":\t    ", gdb_stdout);
              pc += (*tm_print_insn) (pc, &di);
              fputs_unfiltered ("\n", gdb_stdout);
            }
        }
    }
  else
    {
    assembly_only:
      for (pc = low; pc < high; )
        {
          QUIT;
          fputs_unfiltered ("    ", gdb_stdout);
          print_address (pc, gdb_stdout);
          fputs_unfiltered (":\t    ", gdb_stdout);
          pc += (*tm_print_insn) (pc, &di);
          fputs_unfiltered ("\n", gdb_stdout);
        }
    }

  gdb_flush (gdb_stdout);

  return TCL_OK;
}

/* This is the memory_read_func for gdb_disassemble when we are
   disassembling from the exec file. */

static int
gdbtk_dis_asm_read_memory (memaddr, myaddr, len, info)
     bfd_vma memaddr;
     bfd_byte *myaddr;
     int len;
     disassemble_info *info;
{
  extern struct target_ops exec_ops;
  int res;

  errno = 0;
  res = xfer_memory (memaddr, myaddr, len, 0, &exec_ops);

  if (res == len)
    return 0;
  else
    if (errno == 0)
      return EIO;
    else
      return errno;
}

/* This will be passed to qsort to sort the results of the disassembly */

static int
compare_lines (mle1p, mle2p)
     const PTR mle1p;
     const PTR mle2p;
{
  struct my_line_entry *mle1, *mle2;
  int val;

  mle1 = (struct my_line_entry *) mle1p;
  mle2 = (struct my_line_entry *) mle2p;

  val =  mle1->line - mle2->line;

  if (val != 0)
    return val;

  return mle1->start_pc - mle2->start_pc;
}

/* This implements the TCL command `gdb_loc',
 *
 * Arguments:
 *    ?symbol? The symbol or address to locate - defaults to pc
 * Tcl Return:
 *    a list consisting of the following:                                  
 *       basename, function name, filename, line number, address, current pc
 */

static int
gdb_loc (clientData, interp, objc, objv)
     ClientData clientData;
     Tcl_Interp *interp;
     int objc;
     Tcl_Obj *CONST objv[];
{
  char *filename;
  struct symtab_and_line sal;
  struct symbol *sym;
  char *funcname, *fname;
  CORE_ADDR pc;

  if (objc == 1)
    {
      if (selected_frame && (selected_frame->pc != stop_pc))
        {
          /* Note - this next line is not correct on all architectures. */
          /* For a graphical debugger we really want to highlight the */
          /* assembly line that called the next function on the stack. */
          /* Many architectures have the next instruction saved as the */
          /* pc on the stack, so what happens is the next instruction */
          /* is highlighted. FIXME */
          pc = selected_frame->pc;
          sal = find_pc_line (selected_frame->pc,
                              selected_frame->next != NULL
                              && !selected_frame->next->signal_handler_caller
                              && !frame_in_dummy (selected_frame->next));
        }
      else
        {
          pc = stop_pc;
          sal = find_pc_line (stop_pc, 0);
        }
    }
  else if (objc == 2)
    {
      struct symtabs_and_lines sals;
      int nelts;

      sals = decode_line_spec (Tcl_GetStringFromObj (objv[1], NULL), 1);

      nelts = sals.nelts;
      sal = sals.sals[0];
      free (sals.sals);

      if (sals.nelts != 1)
        {
          Tcl_SetStringObj (result_ptr->obj_ptr, "Ambiguous line spec", -1);
          return TCL_ERROR;
        }
      resolve_sal_pc (&sal);
      pc = sal.pc;
    }
  else
    {
      Tcl_SetStringObj (result_ptr->obj_ptr, "wrong # args", -1);
      return TCL_ERROR;
    }

  if (sal.symtab)
    Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
                              Tcl_NewStringObj (sal.symtab->filename, -1));
  else
    Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr, Tcl_NewStringObj ("", 0));

  sym = find_pc_function (pc);
  if (sym != NULL)
    {
      fname = SYMBOL_DEMANGLED_NAME (sym);
      if (fname)
        {
          Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
                                    Tcl_NewStringObj (fname, -1));
        }
      else
        Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
                                  Tcl_NewStringObj (SYMBOL_NAME (sym), -1));
    }
  else
    {
      /* find_pc_function will fail if there are only minimal symbols */
      /* so do this instead... */
      find_pc_partial_function (pc, &funcname, NULL, NULL);
      /* we try cplus demangling; a guess really */
      fname = cplus_demangle (funcname, 0);
      if (fname)
        {
          Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
                                    Tcl_NewStringObj (fname, -1));
          free (fname);
        }
      else
        Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
                                  Tcl_NewStringObj (funcname, -1));
    }
  
  filename = symtab_to_filename (sal.symtab);
  if (filename == NULL)
    filename = "";

  /* file name */
  Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
                            Tcl_NewStringObj (filename, -1));
  /* line number */
  Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr, Tcl_NewIntObj(sal.line));
 /* PC in current frame */
  sprintf_append_element_to_obj (result_ptr->obj_ptr, "0x%s", paddr_nz(pc));
 /* Real PC */
  sprintf_append_element_to_obj (result_ptr->obj_ptr, "0x%s", paddr_nz(stop_pc));

  /* shared library */
#ifdef PC_SOLIB
  Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
                            Tcl_NewStringObj (PC_SOLIB(pc), -1));
#else
  Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
                            Tcl_NewStringObj ("", -1));
#endif
  return TCL_OK;
}

/* This implements the Tcl command 'gdb_get_mem', which 
 * dumps a block of memory 
 * Arguments:
 *   gdb_get_mem addr form size num aschar
 *
 *   addr: address of data to dump
 *   form: a char indicating format
 *   size: size of each element; 1,2,4, or 8 bytes
 *   num: the number of bytes to read 
 *   acshar: an optional ascii character to use in ASCII dump
 * 
 * Return:
 * a list of elements followed by an optional ASCII dump 
 */

static int
gdb_get_mem (clientData, interp, objc, objv)
     ClientData clientData;
     Tcl_Interp *interp;
     int objc;
     Tcl_Obj *CONST objv[];
{
  int size, asize, i, j, bc;
  CORE_ADDR addr;
  int nbytes, rnum, bpr;
  long tmp;
  char format, c, buff[128], aschar, *mbuf, *mptr, *cptr, *bptr;
  struct type *val_type;

  if (objc < 6 || objc > 7)
    {
      Tcl_SetStringObj (result_ptr->obj_ptr,
                        "addr format size bytes bytes_per_row ?ascii_char?", -1);
      return TCL_ERROR; 
    }

  if (Tcl_GetIntFromObj (interp, objv[3], &size) != TCL_OK)
    {
      result_ptr->flags |= GDBTK_IN_TCL_RESULT;
      return TCL_ERROR;
    }
  else if (size <= 0)
    {
      Tcl_SetStringObj (result_ptr->obj_ptr, "Invalid size, must be > 0", -1);
      return TCL_ERROR;
    }
  
  if (Tcl_GetIntFromObj (interp, objv[4], &nbytes) != TCL_OK)
    {
      result_ptr->flags |= GDBTK_IN_TCL_RESULT;
      return TCL_ERROR;
    }
  else if (size <= 0)
    {
      Tcl_SetStringObj (result_ptr->obj_ptr, "Invalid number of bytes, must be > 0", 
                        -1);
      return TCL_ERROR;
    }
  
  if (Tcl_GetIntFromObj (interp, objv[5], &bpr) != TCL_OK)
    {
      result_ptr->flags |= GDBTK_IN_TCL_RESULT;
      return TCL_ERROR;
    }
  else if (size <= 0)
    {
      Tcl_SetStringObj (result_ptr->obj_ptr, "Invalid bytes per row, must be > 0", -1);
      return TCL_ERROR;
    }
  
  if (Tcl_GetLongFromObj (interp, objv[1], &tmp) != TCL_OK)
    return TCL_OK;

  addr = (CORE_ADDR) tmp;

  format = *(Tcl_GetStringFromObj (objv[2], NULL));
  mbuf = (char *)malloc (nbytes+32);
  if (!mbuf)
    {
      Tcl_SetStringObj (result_ptr->obj_ptr, "Out of memory.", -1);
      return TCL_ERROR;
    }
  
  memset (mbuf, 0, nbytes+32);
  mptr = cptr = mbuf;

  rnum = target_read_memory_partial (addr, mbuf, nbytes, NULL);

  if (objc == 7)
    aschar = *(Tcl_GetStringFromObj(objv[6], NULL)); 
  else
    aschar = 0;

  switch (size) {
  case 1:
    val_type = builtin_type_char;
    asize = 'b';
    break;
  case 2:
    val_type = builtin_type_short;
    asize = 'h';
    break;
  case 4:
    val_type = builtin_type_int;
    asize = 'w';
    break;
  case 8:
    val_type = builtin_type_long_long;
    asize = 'g';
    break;
  default:
    val_type = builtin_type_char;
    asize = 'b';
  }

  bc = 0;        /* count of bytes in a row */
  buff[0] = '"'; /* buffer for ascii dump */
  bptr = &buff[1];   /* pointer for ascii dump */
  
  result_ptr->flags |= GDBTK_MAKES_LIST; /* Build up the result as a list... */
   
  for (i=0; i < nbytes; i+= size)
    {
      if ( i >= rnum)
        {
          fputs_unfiltered ("N/A ", gdb_stdout);
          if (aschar)
            for ( j = 0; j < size; j++)
              *bptr++ = 'X';
        }
      else
        {
          print_scalar_formatted (mptr, val_type, format, asize, gdb_stdout);

          if (aschar)
            {
              for ( j = 0; j < size; j++)
                {
                  c = *cptr++;
                  if (c < 32 || c > 126)
                    c = aschar;
                  if (c == '"')
                    *bptr++ = '\\';
                  *bptr++ = c;
                }
            }
        }

      mptr += size;
      bc += size;

      if (aschar && (bc >= bpr))
        {
          /* end of row. print it and reset variables */
          bc = 0;
          *bptr++ = '"';
          *bptr++ = ' ';
          *bptr = 0;
          fputs_unfiltered (buff, gdb_stdout);
          bptr = &buff[1];
        }
    }
  
  result_ptr->flags &= ~GDBTK_MAKES_LIST;
            
  free (mbuf);
  return TCL_OK;
}

\f

/* This implements the tcl command "gdb_loadfile"
 * It loads a c source file into a text widget.
 *
 * Tcl Arguments:
 *    widget: the name of the text widget to fill
 *    filename: the name of the file to load
 *    linenumbers: A boolean indicating whether or not to display line numbers.
 * Tcl Result:
 *
 */

/* In this routine, we will build up a "line table", i.e. a
 * table of bits showing which lines in the source file are executible.
 * LTABLE_SIZE is the number of bytes to allocate for the line table.
 *
 * Its size limits the maximum number of lines 
 * in a file to 8 * LTABLE_SIZE.  This memory is freed after 
 * the file is loaded, so it is OK to make this very large. 
 * Additional memory will be allocated if needed. */
#define LTABLE_SIZE 20000
static int
gdb_loadfile (clientData, interp, objc, objv)
  ClientData clientData;
  Tcl_Interp *interp;
  int objc;
  Tcl_Obj *CONST objv[];
{
  char *file, *widget;
  int linenumbers, ln, lnum, ltable_size;
  FILE *fp;
  char *ltable;
  struct symtab *symtab;
  struct linetable_entry *le;
  long mtime = 0;
  struct stat st;
  Tcl_DString text_cmd_1, text_cmd_2, *cur_cmd;
  char line[10000], line_num_buf[16];
  int prefix_len_1, prefix_len_2, cur_prefix_len, widget_len;

 
  if (objc != 4)
    {
      Tcl_WrongNumArgs(interp, 1, objv, "widget filename linenumbers");
      return TCL_ERROR; 
    }

  widget = Tcl_GetStringFromObj (objv[1], NULL);
  if ( Tk_NameToWindow (interp, widget, Tk_MainWindow (interp)) == NULL)
    {
      return TCL_ERROR;
    }
  
  file  = Tcl_GetStringFromObj (objv[2], NULL);
  Tcl_GetBooleanFromObj (interp, objv[3], &linenumbers);

  symtab = full_lookup_symtab (file);
  if (!symtab)
    {
      Tcl_SetStringObj ( result_ptr->obj_ptr, "File not found in symtab", -1);
      fclose (fp);
      return TCL_ERROR;
    }

  file = symtab_to_filename ( symtab );
  if ((fp = fopen ( file, "r" )) == NULL)
    {
      Tcl_SetStringObj ( result_ptr->obj_ptr, "Can't open file for reading", -1);
      return TCL_ERROR;
    }

  if (stat (file, &st) < 0)
    {
      catch_errors (perror_with_name_wrapper, "gdbtk: get time stamp", "",
                    RETURN_MASK_ALL);
      return TCL_ERROR;
    }

  if (symtab && symtab->objfile && symtab->objfile->obfd)
      mtime = bfd_get_mtime(symtab->objfile->obfd);
  else if (exec_bfd)
      mtime = bfd_get_mtime(exec_bfd);
 
  if (mtime && mtime < st.st_mtime)
     gdbtk_ignorable_warning("Source file is more recent than executable.\n");


  /* Source linenumbers don't appear to be in order, and a sort is */
  /* too slow so the fastest solution is just to allocate a huge */
  /* array and set the array entry for each linenumber */

  ltable_size = LTABLE_SIZE;
  ltable = (char *)malloc (LTABLE_SIZE);
  if (ltable == NULL)
    {
      Tcl_SetStringObj ( result_ptr->obj_ptr, "Out of memory.", -1);
      fclose (fp);
      return TCL_ERROR;
    }

  memset (ltable, 0, LTABLE_SIZE);

  if (symtab->linetable && symtab->linetable->nitems)
    {
      le = symtab->linetable->item;
      for (ln = symtab->linetable->nitems ;ln > 0; ln--, le++)
        {
          lnum = le->line >> 3;
          if (lnum >= ltable_size)
            {
              char *new_ltable;
              new_ltable = (char *)realloc (ltable, ltable_size*2);
              memset (new_ltable + ltable_size, 0, ltable_size);
              ltable_size *= 2;
              if (new_ltable == NULL)
                {
                  Tcl_SetStringObj ( result_ptr->obj_ptr, "Out of memory.", -1);
                  free (ltable);
                  fclose (fp);
                  return TCL_ERROR;
                }
              ltable = new_ltable;
            }
          ltable[lnum] |= 1 << (le->line % 8);
        }
    }
    
  Tcl_DStringInit(&text_cmd_1);
  Tcl_DStringInit(&text_cmd_2);
  
  ln = 1;

  widget_len = strlen (widget);
  line[0] = '\t';
  
  Tcl_DStringAppend (&text_cmd_1, widget, widget_len);
  Tcl_DStringAppend (&text_cmd_2, widget, widget_len);
  
  if (linenumbers)
    {
      Tcl_DStringAppend (&text_cmd_1, " insert end {-\t", -1);
      prefix_len_1 = Tcl_DStringLength(&text_cmd_1);

      Tcl_DStringAppend (&text_cmd_2, " insert end { \t", -1);
      prefix_len_2 = Tcl_DStringLength(&text_cmd_2);
      
      while (fgets (line + 1, 9980, fp))
        {
          sprintf (line_num_buf, "%d", ln);
          if (ltable[ln >> 3] & (1 << (ln % 8)))
            {
              cur_cmd = &text_cmd_1;
              cur_prefix_len = prefix_len_1;
              Tcl_DStringAppend (cur_cmd, line_num_buf, -1);
              Tcl_DStringAppend (cur_cmd, "} break_rgn_tag", 15);
            }
          else
            {
              cur_cmd = &text_cmd_2;
              cur_prefix_len = prefix_len_2;
              Tcl_DStringAppend (cur_cmd, line_num_buf, -1);
              Tcl_DStringAppend (cur_cmd, "} \"\"", 4);
            }

          Tcl_DStringAppendElement (cur_cmd, line);
          Tcl_DStringAppend (cur_cmd, " source_tag", 11);

          Tcl_Eval(interp, Tcl_DStringValue(cur_cmd));
          Tcl_DStringSetLength(cur_cmd, cur_prefix_len);
          ln++;
        }
    }
  else
    {
      Tcl_DStringAppend (&text_cmd_1, " insert end {- } break_rgn_tag", -1);
      prefix_len_1 = Tcl_DStringLength(&text_cmd_1);
      Tcl_DStringAppend (&text_cmd_2, " insert end {  } \"\"", -1);
      prefix_len_2 = Tcl_DStringLength(&text_cmd_2);

      while (fgets (line + 1, 980, fp))
        {
          if (ltable[ln >> 3] & (1 << (ln % 8)))
            {
              cur_cmd = &text_cmd_1;
              cur_prefix_len = prefix_len_1;
            }
          else
            {
              cur_cmd = &text_cmd_2;
              cur_prefix_len = prefix_len_2;
            }

          Tcl_DStringAppendElement (cur_cmd, line);
          Tcl_DStringAppend (cur_cmd, " source_tag", 11);

          Tcl_Eval(interp, Tcl_DStringValue(cur_cmd));
          Tcl_DStringSetLength(cur_cmd, cur_prefix_len);

          ln++;
        }
    }

  Tcl_DStringFree (&text_cmd_1);
  Tcl_DStringFree (&text_cmd_2);
  free (ltable);
  fclose (fp);
  return TCL_OK;
}
\f
/*
 *  This section contains commands for manipulation of breakpoints.
 */


/* set a breakpoint by source file and line number */
/* flags are as follows: */
/* least significant 2 bits are disposition, rest is */
/* type (normally 0).

enum bptype {
  bp_breakpoint,                 Normal breakpoint 
  bp_hardware_breakpoint,       Hardware assisted breakpoint
}

Disposition of breakpoint.  Ie: what to do after hitting it.
enum bpdisp {
  del,                          Delete it
  del_at_next_stop,             Delete at next stop, whether hit or not
  disable,                      Disable it 
  donttouch                     Leave it alone 
  };
*/

/* This implements the tcl command "gdb_set_bp"
 * It sets breakpoints, and runs the Tcl command
 *     gdbtk_tcl_breakpoint create
 * to register the new breakpoint with the GUI.
 *
 * Tcl Arguments:
 *    filename: the file in which to set the breakpoint
 *    line:     the line number for the breakpoint
 *    type:     the type of the breakpoint
 *    thread:   optional thread number
 * Tcl Result:
 *    The return value of the call to gdbtk_tcl_breakpoint.
 */

static int
gdb_set_bp (clientData, interp, objc, objv)
  ClientData clientData;
  Tcl_Interp *interp;
  int objc;
  Tcl_Obj *CONST objv[];
{
  struct symtab_and_line sal;
  int line, ret, thread = -1;
  struct breakpoint *b;
  char buf[64], *typestr;
  Tcl_DString cmd;
  enum bpdisp disp;

  if (objc != 4 && objc != 5)
    {
      Tcl_SetStringObj (result_ptr->obj_ptr, 
          "wrong number of args, should be \"filename line type [thread]\"", -1);
      return TCL_ERROR; 
    }
  
  sal.symtab = full_lookup_symtab (Tcl_GetStringFromObj( objv[1], NULL));
  if (sal.symtab == NULL)
    return TCL_ERROR;
  
  if (Tcl_GetIntFromObj( interp, objv[2], &line) == TCL_ERROR)
    {
      result_ptr->flags = GDBTK_IN_TCL_RESULT;
      return TCL_ERROR;
    }
  
  typestr = Tcl_GetStringFromObj( objv[3], NULL);
  if (typestr == NULL)
    {
      result_ptr->flags = GDBTK_IN_TCL_RESULT;
      return TCL_ERROR;
    }
  if (strncmp( typestr, "temp", 4 ) == 0)
    disp = del;
  else if (strncmp( typestr, "normal", 6 ) == 0)
    disp = donttouch;
  else
    {
      Tcl_SetStringObj (result_ptr->obj_ptr, "type must be \"temp\" or \"normal\"", -1);
      return TCL_ERROR;
    }
  
  if (objc == 5)
    {
      if (Tcl_GetIntFromObj( interp, objv[4], &thread) == TCL_ERROR)
        {
          result_ptr->flags = GDBTK_IN_TCL_RESULT;
          return TCL_ERROR;
        }
    }

  sal.line = line;
  if (!find_line_pc (sal.symtab, sal.line, &sal.pc))
    return TCL_ERROR;

  sal.section = find_pc_overlay (sal.pc);
  b = set_raw_breakpoint (sal);
  set_breakpoint_count (breakpoint_count + 1);
  b->number = breakpoint_count;
  b->type = bp_breakpoint;
  b->disposition = disp;
  b->thread = thread;

  /* FIXME: this won't work for duplicate basenames! */
  sprintf (buf, "%s:%d", basename (Tcl_GetStringFromObj ( objv[1], NULL)), line);
  b->addr_string = strsave (buf);

  /* now send notification command back to GUI */

  Tcl_DStringInit (&cmd);

  Tcl_DStringAppend (&cmd, "gdbtk_tcl_breakpoint create ", -1);
  sprintf (buf, "%d", b->number);
  Tcl_DStringAppendElement(&cmd, buf);
  sprintf (buf, "0x%lx", (long)sal.pc);
  Tcl_DStringAppendElement (&cmd, buf);
  Tcl_DStringAppendElement (&cmd, Tcl_GetStringFromObj (objv[2], NULL));
  Tcl_DStringAppendElement (&cmd, Tcl_GetStringFromObj (objv[1], NULL));
  Tcl_DStringAppendElement (&cmd, bpdisp[b->disposition]);
  sprintf (buf, "%d", b->enable);
  Tcl_DStringAppendElement (&cmd, buf);
  sprintf (buf, "%d", b->thread);
  Tcl_DStringAppendElement (&cmd, buf);
  

  ret = Tcl_Eval (interp, Tcl_DStringValue (&cmd));
  Tcl_DStringFree (&cmd);
  return ret;
}

/* This implements the tcl command "gdb_set_bp_addr"
 * It sets breakpoints, and runs the Tcl command
 *     gdbtk_tcl_breakpoint create
 * to register the new breakpoint with the GUI.
 *
 * Tcl Arguments:
 *    addr: the address at which to set the breakpoint
 *    type:     the type of the breakpoint
 *    thread:   optional thread number
 * Tcl Result:
 *    The return value of the call to gdbtk_tcl_breakpoint.
 */

static int
gdb_set_bp_addr (clientData, interp, objc, objv)
  ClientData clientData;
  Tcl_Interp *interp;
  int objc;
  Tcl_Obj *CONST objv[];

{
  struct symtab_and_line sal;
  int line, ret, thread = -1;
  long addr;
  struct breakpoint *b;
  char *filename, *typestr, buf[64];
  Tcl_DString cmd;
  enum bpdisp disp;

  if (objc != 4 && objc != 3)
    {
      Tcl_SetStringObj (result_ptr->obj_ptr, 
          "wrong number of args, should be \"address type [thread]\"", -1);
      return TCL_ERROR; 
    }
  
  if (Tcl_GetLongFromObj( interp, objv[1], &addr) == TCL_ERROR)
    {
      result_ptr->flags = GDBTK_IN_TCL_RESULT;
      return TCL_ERROR;
    }
  
  typestr = Tcl_GetStringFromObj( objv[2], NULL);
  if (typestr == NULL)
    {
      result_ptr->flags = GDBTK_IN_TCL_RESULT;
      return TCL_ERROR;
    }
  if (strncmp( typestr, "temp", 4 ) == 0)
    disp = del;
  else if (strncmp( typestr, "normal", 6 ) == 0)
    disp = donttouch;
  else
    {
      Tcl_SetStringObj (result_ptr->obj_ptr, "type must be \"temp\" or \"normal\"", -1);
      return TCL_ERROR;
    }
  
  if (objc == 4)
    {
      if (Tcl_GetIntFromObj( interp, objv[3], &thread) == TCL_ERROR)
        {
          result_ptr->flags = GDBTK_IN_TCL_RESULT;
          return TCL_ERROR;
        }
    }

  sal = find_pc_line (addr, 0);
  sal.pc = addr;
  b = set_raw_breakpoint (sal);
  set_breakpoint_count (breakpoint_count + 1);
  b->number = breakpoint_count;
  b->type = bp_breakpoint;
  b->disposition = disp;
  b->thread = thread;

  sprintf (buf, "*(0x%lx)",addr);
  b->addr_string = strsave (buf);

  /* now send notification command back to GUI */

  Tcl_DStringInit (&cmd);

  Tcl_DStringAppend (&cmd, "gdbtk_tcl_breakpoint create ", -1);
  sprintf (buf, "%d", b->number);
  Tcl_DStringAppendElement(&cmd, buf);
  sprintf (buf, "0x%lx", addr);
  Tcl_DStringAppendElement (&cmd, buf);
  sprintf (buf, "%d", b->line_number);
  Tcl_DStringAppendElement (&cmd, buf);

  filename = symtab_to_filename (sal.symtab);
  if (filename == NULL)
    filename = "";
  Tcl_DStringAppendElement (&cmd, filename);
  Tcl_DStringAppendElement (&cmd, bpdisp[b->disposition]);
  sprintf (buf, "%d", b->enable);
  Tcl_DStringAppendElement (&cmd, buf);
  sprintf (buf, "%d", b->thread);
  Tcl_DStringAppendElement (&cmd, buf);

  ret = Tcl_Eval (interp, Tcl_DStringValue (&cmd));
  Tcl_DStringFree (&cmd);
  return ret;
}

/* This implements the tcl command "gdb_find_bp_at_line"
 *
 * Tcl Arguments:
 *    filename: the file in which to find the breakpoint
 *    line:     the line number for the breakpoint
 * Tcl Result:
 *    It returns a list of breakpoint numbers
 */

static int
gdb_find_bp_at_line(clientData, interp, objc, objv)
  ClientData clientData;
  Tcl_Interp *interp;
  int objc;
  Tcl_Obj *CONST objv[];

{
  struct symtab *s;
  int line;
  struct breakpoint *b;
  extern struct breakpoint *breakpoint_chain;

  if (objc != 3)
    {
      Tcl_WrongNumArgs(interp, 1, objv, "filename line");
      return TCL_ERROR; 
    }
  
  s = full_lookup_symtab (Tcl_GetStringFromObj( objv[1], NULL));
  if (s == NULL)
    return TCL_ERROR;
  
  if (Tcl_GetIntFromObj( interp, objv[2], &line) == TCL_ERROR)
    {
      result_ptr->flags = GDBTK_IN_TCL_RESULT;
      return TCL_ERROR;
    }

  Tcl_SetListObj (result_ptr->obj_ptr ,0 ,NULL);
  for (b = breakpoint_chain; b; b = b->next)
    if (b->line_number == line && !strcmp(b->source_file, s->filename))
      Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
                                Tcl_NewIntObj (b->number));
  
  return TCL_OK;
}


/* This implements the tcl command "gdb_find_bp_at_addr"
 *
 * Tcl Arguments:
 *    addr:     address
 * Tcl Result:
 *    It returns a list of breakpoint numbers
 */

static int
gdb_find_bp_at_addr(clientData, interp, objc, objv)
  ClientData clientData;
  Tcl_Interp *interp;
  int objc;
  Tcl_Obj *CONST objv[];

{
  long addr;
  struct breakpoint *b;
  extern struct breakpoint *breakpoint_chain;

  if (objc != 2)
    {
      Tcl_WrongNumArgs(interp, 1, objv, "address");
      return TCL_ERROR; 
    }
  
  if (Tcl_GetLongFromObj( interp, objv[1], &addr) == TCL_ERROR)
    {
      result_ptr->flags = GDBTK_IN_TCL_RESULT;
      return TCL_ERROR;
    }

  Tcl_SetListObj (result_ptr->obj_ptr ,0 ,NULL);
  for (b = breakpoint_chain; b; b = b->next)
    if (b->address == (CORE_ADDR)addr)
      Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
                                Tcl_NewIntObj (b->number));

  return TCL_OK;
}

/* This implements the tcl command gdb_get_breakpoint_info
 *
 *
 * Tcl Arguments:
 *   breakpoint_number
 * Tcl Result:
 *   A list with {file, function, line_number, address, type, enabled?,
 *                disposition, ignore_count, {list_of_commands}, thread, hit_count}
 */

static int
gdb_get_breakpoint_info (clientData, interp, objc, objv)
     ClientData clientData;
     Tcl_Interp *interp;
     int objc;
     Tcl_Obj *CONST objv[];
{
  struct symtab_and_line sal;
  struct command_line *cmd;
  int bpnum;
  struct breakpoint *b;
  extern struct breakpoint *breakpoint_chain;
  char *funcname, *fname, *filename;
  Tcl_Obj *new_obj;

  if (objc != 2)
    {
      Tcl_SetStringObj (result_ptr->obj_ptr, "wrong number of args, should be \"breakpoint\"", -1);
      return TCL_ERROR;
    }

  if ( Tcl_GetIntFromObj(NULL, objv[1], &bpnum) != TCL_OK)
    {
      result_ptr->flags = GDBTK_IN_TCL_RESULT;
      return TCL_ERROR;
    }

  for (b = breakpoint_chain; b; b = b->next)
    if (b->number == bpnum)
      break;

  if (!b || b->type != bp_breakpoint)
    {
      char err_buf[64];
      sprintf(err_buf, "Breakpoint #%d does not exist.", bpnum);
      Tcl_SetStringObj (result_ptr->obj_ptr, err_buf, -1);
      return TCL_ERROR;
    }

  sal = find_pc_line (b->address, 0);

  filename = symtab_to_filename (sal.symtab);
  if (filename == NULL)
    filename = "";

  Tcl_SetListObj (result_ptr->obj_ptr ,0 ,NULL);
  Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
          Tcl_NewStringObj (filename, -1));

  find_pc_partial_function (b->address, &funcname, NULL, NULL);
  fname = cplus_demangle (funcname, 0);
  if (fname)
    {
      new_obj = Tcl_NewStringObj (fname, -1);
      free (fname);
    }
  else
    new_obj = Tcl_NewStringObj (funcname, -1);

  Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr, new_obj);
  
  Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr, Tcl_NewIntObj (b->line_number));
  sprintf_append_element_to_obj (result_ptr->obj_ptr, "0x%s", paddr_nz(b->address));
  Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
                            Tcl_NewStringObj (bptypes[b->type], -1));
  Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr, Tcl_NewBooleanObj(b->enable == enabled));
  Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
                            Tcl_NewStringObj (bpdisp[b->disposition], -1));
  Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr, Tcl_NewIntObj (b->ignore_count));

  new_obj = Tcl_NewObj();
  for (cmd = b->commands; cmd; cmd = cmd->next)
    Tcl_ListObjAppendElement (NULL, new_obj,
                              Tcl_NewStringObj (cmd->line, -1));
  Tcl_ListObjAppendElement(NULL, result_ptr->obj_ptr, new_obj);
                              
  Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
                            Tcl_NewStringObj (b->cond_string, -1));

  Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr, Tcl_NewIntObj (b->thread));
  Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr, Tcl_NewIntObj (b->hit_count));

  return TCL_OK;
}


/* This implements the tcl command gdb_get_breakpoint_list
 * It builds up a list of the current breakpoints.
 *
 * Tcl Arguments:
 *    None.
 * Tcl Result:
 *    A list of breakpoint numbers.
 */

static int
gdb_get_breakpoint_list (clientData, interp, objc, objv)
     ClientData clientData;
     Tcl_Interp *interp;
     int objc;
     Tcl_Obj *CONST objv[];
{
  struct breakpoint *b;
  extern struct breakpoint *breakpoint_chain;
  Tcl_Obj *new_obj;

  if (objc != 1)
    error ("wrong number of args, none are allowed");

  for (b = breakpoint_chain; b; b = b->next)
    if (b->type == bp_breakpoint)
      {
        new_obj = Tcl_NewIntObj (b->number);
        Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr, new_obj);
      }

  return TCL_OK;
}
\f
/* The functions in this section deal with stacks and backtraces. */

/* This implements the tcl command gdb_stack.
 * It builds up a list of stack frames.
 *
 * Tcl Arguments:
 *    start  - starting stack frame
 *    count - number of frames to inspect
 * Tcl Result:
 *    A list of function names
 */

static int
gdb_stack (clientData, interp, objc, objv)     ClientData clientData;
     Tcl_Interp *interp;
     int objc;
     Tcl_Obj *CONST objv[];
{
  int start, count;

  if (objc < 3)
    {
      Tcl_WrongNumArgs (interp, 1, objv, "start count");
      result_ptr->flags |= GDBTK_IN_TCL_RESULT;
      return TCL_ERROR;
    }

  if (Tcl_GetIntFromObj (NULL, objv[1], &start))
    {
      result_ptr->flags |= GDBTK_IN_TCL_RESULT;
      return TCL_ERROR;
    }
  if (Tcl_GetIntFromObj (NULL, objv[2], &count))
    {
      result_ptr->flags |= GDBTK_IN_TCL_RESULT;
      return TCL_ERROR;
    }

  Tcl_SetListObj (result_ptr->obj_ptr, 0, NULL);

  if (target_has_stack)
    {
      struct frame_info *top;
      struct frame_info *fi;

      /* Find the outermost frame */
      fi = get_current_frame ();
      while (fi != NULL)
        {
          top = fi;
          fi = get_prev_frame (fi);
        }

      /* top now points to the top (outermost frame) of the
         stack, so point it to the requested start */
      start = -start;
      top   = find_relative_frame (top, &start);

      /* If start != 0, then we have asked to start outputting
         frames beyond the innermost stack frame */
      if (start == 0)
        {
          fi = top; 
          while (fi && count--)
            {
              get_frame_name (interp, result_ptr->obj_ptr, fi);
              fi = get_next_frame (fi);
            }
        }
    }

  return TCL_OK;
}

/* A helper function for get_stack which adds information about
 * the stack frame FI to the caller's LIST.
 *
 * This is stolen from print_frame_info in stack.c.
 */
static void
get_frame_name (interp, list, fi)
     Tcl_Interp *interp;
     Tcl_Obj *list;
     struct frame_info *fi;
{
  struct symtab_and_line sal;
  struct symbol *func = NULL;
  register char *funname = 0;
  enum language funlang = language_unknown;
  Tcl_Obj *objv[1];

  if (frame_in_dummy (fi))
    {
      objv[0] = Tcl_NewStringObj ("<function called from gdb>\n", -1);
      Tcl_ListObjAppendElement (interp, list, objv[0]);
      return;
    }
  if (fi->signal_handler_caller)
    {
      objv[0] = Tcl_NewStringObj ("<signal handler called>\n", -1);
      Tcl_ListObjAppendElement (interp, list, objv[0]);
      return;
    }

  sal =
    find_pc_line (fi->pc,
                  fi->next != NULL
                  && !fi->next->signal_handler_caller
                  && !frame_in_dummy (fi->next));
  
  func = find_pc_function (fi->pc);
  if (func)
    {
      struct minimal_symbol *msymbol = lookup_minimal_symbol_by_pc (fi->pc);
      if (msymbol != NULL
          && (SYMBOL_VALUE_ADDRESS (msymbol) 
              > BLOCK_START (SYMBOL_BLOCK_VALUE (func))))
        {
          func = 0;
          funname = GDBTK_SYMBOL_SOURCE_NAME (msymbol);
          funlang = SYMBOL_LANGUAGE (msymbol);
        }
      else
        {
          funname = GDBTK_SYMBOL_SOURCE_NAME (func);
          funlang = SYMBOL_LANGUAGE (func);
        }
    }
  else
    {
      struct minimal_symbol *msymbol = lookup_minimal_symbol_by_pc (fi->pc);
      if (msymbol != NULL)
        {
          funname = GDBTK_SYMBOL_SOURCE_NAME (msymbol);
          funlang = SYMBOL_LANGUAGE (msymbol);
        }
    }
  
  if (sal.symtab)
    {
      char *name = NULL;

      objv[0] = Tcl_NewStringObj (funname, -1);
      Tcl_ListObjAppendElement (interp, list, objv[0]);
    }
  else
    {
#if 0
      /* we have no convenient way to deal with this yet... */
      if (fi->pc != sal.pc || !sal.symtab)
        {
          print_address_numeric (fi->pc, 1, gdb_stdout);
          printf_filtered (" in ");
        }
      printf_symbol_filtered (gdb_stdout, funname ? funname : "??", funlang,
                               DMGL_ANSI);
#endif
      objv[0] = Tcl_NewStringObj (funname != NULL ? funname : "??", -1);
#ifdef PC_LOAD_SEGMENT
      /* If we couldn't print out function name but if can figure out what
         load segment this pc value is from, at least print out some info
         about its load segment. */
      if (!funname)
        {
          Tcl_AppendStringsToObj (objv[0], " from ", PC_LOAD_SEGMENT (fi->pc),
                                  (char *) NULL);
        }
#endif
#ifdef PC_SOLIB
      if (!funname)
        {
          char *lib = PC_SOLIB (fi->pc);
          if (lib)
            {
              Tcl_AppendStringsToObj (objv[0], " from ", lib, (char *) NULL);
            }
        }
#endif
      Tcl_ListObjAppendElement (interp, list, objv[0]);
    }
}

\f
/*
 * This section contains a bunch of miscellaneous utility commands
 */

/* This implements the tcl command gdb_path_conv
 *
 * On Windows, it canonicalizes the pathname,
 * On Unix, it is a no op.
 *
 * Arguments:
 *    path
 * Tcl Result:
 *    The canonicalized path.
 */

static int
gdb_path_conv (clientData, interp, objc, objv)
     ClientData clientData;
     Tcl_Interp *interp;
     int objc;
     Tcl_Obj *CONST objv[];
{
  if (objc != 2)
    error ("wrong # args");
  
#ifdef __CYGWIN__
  {
    char pathname[256], *ptr;

    cygwin32_conv_to_full_win32_path (Tcl_GetStringFromObj (objv[1], NULL), pathname);
    for (ptr = pathname; *ptr; ptr++)
      {
        if (*ptr == '\\')
          *ptr = '/';
      }
    Tcl_SetStringObj (result_ptr->obj_ptr, pathname, -1);
  }
#else
  Tcl_SetStringObj (result_ptr->obj_ptr, Tcl_GetStringFromObj (objv[1], NULL), -1);
#endif

  return TCL_OK;
}
\f
/*
 * This section has utility routines that are not Tcl commands.
 */

static int
perror_with_name_wrapper (args)
  char * args;
{
  perror_with_name (args);
  return 1;
}

/* The lookup_symtab() in symtab.c doesn't work correctly */
/* It will not work will full pathnames and if multiple */
/* source files have the same basename, it will return */
/* the first one instead of the correct one.  This version */
/* also always makes sure symtab->fullname is set. */

static struct symtab *
full_lookup_symtab(file)
     char *file;
{
  struct symtab *st;
  struct objfile *objfile;
  char *bfile, *fullname;
  struct partial_symtab *pt;

  if (!file)
    return NULL;

  /* first try a direct lookup */
  st = lookup_symtab (file);
  if (st)
    {
      if (!st->fullname)
          symtab_to_filename(st);
      return st;
    }
  
  /* if the direct approach failed, try */
  /* looking up the basename and checking */
  /* all matches with the fullname */
  bfile = basename (file);
  ALL_SYMTABS (objfile, st)
    {
      if (!strcmp (bfile, basename(st->filename)))
        {
          if (!st->fullname)
            fullname = symtab_to_filename (st);
          else
            fullname = st->fullname;

          if (!strcmp (file, fullname))
            return st;
        }
    }
  
  /* still no luck?  look at psymtabs */
  ALL_PSYMTABS (objfile, pt)
    {
      if (!strcmp (bfile, basename(pt->filename)))
        {
          st = PSYMTAB_TO_SYMTAB (pt);
          if (st)
            {
              fullname = symtab_to_filename (st);
              if (!strcmp (file, fullname))
                return st;
            }
        }
    }
  return NULL;
}
\f
/* Local variables: */
/* change-log-default-name: "ChangeLog-gdbtk" */
/* End: */