Subversion Repositories or1k

/* Tcl/Tk command definitions for Insight - Stack.

   Copyright 2001 Free Software Foundation, Inc.

   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 "frame.h"

#include "value.h"

#include "target.h"

#include "breakpoint.h"

#include "linespec.h"

#include <tcl.h>

#include "gdbtk.h"

#include "gdbtk-cmds.h"

#include "gdbtk-wrapper.h"

static int gdb_block_vars (ClientData clientData,

                           Tcl_Interp * interp, int objc,

                           Tcl_Obj * CONST objv[]);

static int gdb_get_args_command (ClientData, Tcl_Interp *, int,

                                 Tcl_Obj * CONST objv[]);

static int gdb_get_blocks (ClientData clientData,

                           Tcl_Interp * interp, int objc,

                           Tcl_Obj * CONST objv[]);

static int gdb_get_locals_command (ClientData, Tcl_Interp *, int,

                                   Tcl_Obj * CONST objv[]);

static int gdb_get_vars_command (ClientData, Tcl_Interp *, int,

                                 Tcl_Obj * CONST objv[]);

static int gdb_selected_block (ClientData clientData,

                               Tcl_Interp * interp, int argc,

                               Tcl_Obj * CONST objv[]);

static int gdb_selected_frame (ClientData clientData,

                               Tcl_Interp * interp, int argc,

                               Tcl_Obj * CONST objv[]);

static int gdb_stack (ClientData, Tcl_Interp *, int, Tcl_Obj * CONST[]);

static void get_frame_name (Tcl_Interp *interp, Tcl_Obj *list,

                            struct frame_info *fi);

int

Gdbtk_Stack_Init (Tcl_Interp *interp)

{

  Tcl_CreateObjCommand (interp, "gdb_block_variables", gdbtk_call_wrapper,

                        gdb_block_vars, NULL);

  Tcl_CreateObjCommand (interp, "gdb_get_blocks", gdbtk_call_wrapper,

                        gdb_get_blocks, NULL);

  Tcl_CreateObjCommand (interp, "gdb_get_args", gdbtk_call_wrapper,

                        gdb_get_args_command, NULL);

  Tcl_CreateObjCommand (interp, "gdb_get_locals", gdbtk_call_wrapper,

                        gdb_get_locals_command, NULL);

  Tcl_CreateObjCommand (interp, "gdb_selected_block", gdbtk_call_wrapper,

                        gdb_selected_block, NULL);

  Tcl_CreateObjCommand (interp, "gdb_selected_frame", gdbtk_call_wrapper,

                        gdb_selected_frame, NULL);

  Tcl_CreateObjCommand (interp, "gdb_stack", gdbtk_call_wrapper, gdb_stack, NULL);

  Tcl_LinkVar (interp, "gdb_selected_frame_level",

               (char *) &selected_frame_level,

               TCL_LINK_INT | TCL_LINK_READ_ONLY);

  return TCL_OK;

}

/* This implements the tcl command gdb_block_vars.

 *

 * Returns all variables valid in the specified block.

 *

 * Arguments:

 *    The start and end addresses which identify the block.

 * Tcl Result:

 *    All variables defined in the given block.

 */

static int

gdb_block_vars (clientData, interp, objc, objv)

     ClientData clientData;

     Tcl_Interp *interp;

     int objc;

     Tcl_Obj *CONST objv[];

{

  struct block *block;

  int nsyms, i;

  struct symbol *sym;

  CORE_ADDR start, end;

  if (objc < 3)

    {

      Tcl_WrongNumArgs (interp, 1, objv, "startAddr endAddr");

      result_ptr->flags |= GDBTK_IN_TCL_RESULT;

      return TCL_ERROR;

    }

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

  if (selected_frame == NULL)

    return TCL_OK;

  start = parse_and_eval_address (Tcl_GetStringFromObj (objv[1], NULL));

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

  block = get_frame_block (selected_frame);

  while (block != 0)

    {

      if (BLOCK_START (block) == start && BLOCK_END (block) == end)

        {

          nsyms = BLOCK_NSYMS (block);

          for (i = 0; i < nsyms; i++)

            {

              sym = BLOCK_SYM (block, i);

              switch (SYMBOL_CLASS (sym))

                {

                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           */

                case LOC_LOCAL:           /* stack local           */

                case LOC_BASEREG:         /* basereg local         */

                case LOC_STATIC:          /* static                */

                case LOC_REGISTER:        /* register              */

                  Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr,

                                            Tcl_NewStringObj (SYMBOL_NAME (sym),

                                                              -1));

                  break;

                default:

                  break;

                }

            }

          return TCL_OK;

        }

      else if (BLOCK_FUNCTION (block))

        break;

      else

        block = BLOCK_SUPERBLOCK (block);

    }

  return TCL_OK;

}

/* This implements the tcl command gdb_get_blocks

 *

 * Returns the start and end addresses for all blocks in

 * the selected frame.

 *

 * Arguments:

 *    None

 * Tcl Result:

 *    A list of all valid blocks in the selected_frame.

 */

static int

gdb_get_blocks (clientData, interp, objc, objv)

     ClientData clientData;

     Tcl_Interp *interp;

     int objc;

     Tcl_Obj *CONST objv[];

{

  struct block *block;

  int nsyms, i, junk;

  struct symbol *sym;

  CORE_ADDR pc;

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

  if (selected_frame != NULL)

    {

      block = get_frame_block (selected_frame);

      pc = get_frame_pc (selected_frame);

      while (block != 0)

        {

          nsyms = BLOCK_NSYMS (block);

          junk = 0;

          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         */

                  junk = 1;

                  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           */

                case LOC_LOCAL:           /* stack local           */

                case LOC_BASEREG:         /* basereg local         */

                case LOC_STATIC:          /* static                */

                case LOC_REGISTER:        /* register              */

                  junk = 0;

                  break;

                }

            }

          /* If we found a block with locals in it, add it to the list.

             Note that the ranges of start and end address for blocks

             are exclusive, so double-check against the PC */

          if (!junk && pc < BLOCK_END (block))

            {

              char *addr;

              Tcl_Obj *elt = Tcl_NewListObj (0, NULL);

              xasprintf (&addr, "0x%s", paddr_nz (BLOCK_START (block)));

              Tcl_ListObjAppendElement (interp, elt,

                                        Tcl_NewStringObj (addr, -1));

              free(addr);

              xasprintf (&addr, "0x%s", paddr_nz (BLOCK_END (block)));

              Tcl_ListObjAppendElement (interp, elt,

                                        Tcl_NewStringObj (addr, -1));

              Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr, elt);

              free(addr);

            }

          if (BLOCK_FUNCTION (block))

            break;

          else

            block = BLOCK_SUPERBLOCK (block);

        }

    }

  return TCL_OK;

}

/* gdb_get_args -

 * 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_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);

}

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);

}

/* 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:

 *   linespec - the linespec defining the scope of the lookup. Empty string

 *              to use the current block in the innermost frame.

 * 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_WrongNumArgs (interp, 1, objv,

                        "[function:line|function|line|*addr]");

      return TCL_ERROR;

    }

  arguments = (int) clientData;

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

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

  if (objc == 2)

    {

      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;

        }

      /* 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);

    }

  else

    {

      /* Specified currently selected frame */

      if (selected_frame == NULL)

        return TCL_OK;

      block = get_frame_block (selected_frame);

    }

  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_selected_block

 *

 * Returns the start and end addresses of the innermost

 * block in the selected frame.

 *

 * Arguments:

 *    None

 * Tcl Result:

 *    The currently selected block's start and end addresses

 */

static int

gdb_selected_block (clientData, interp, objc, objv)

     ClientData clientData;

     Tcl_Interp *interp;

     int objc;

     Tcl_Obj *CONST objv[];

{

  char *start = NULL;

  char *end   = NULL;

  if (selected_frame == NULL)

    {

      xasprintf (&start, "%s", "");

      xasprintf (&end, "%s", "");

    }

  else

    {

      struct block *block;

      block = get_frame_block (selected_frame);

      xasprintf (&start, "0x%s", paddr_nz (BLOCK_START (block)));

      xasprintf (&end, "0x%s", paddr_nz (BLOCK_END (block)));

    }

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

  Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr,

                            Tcl_NewStringObj (start, -1));

  Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr,

                            Tcl_NewStringObj (end, -1));

  free(start);

  free(end);

  return TCL_OK;

}

/* This implements the tcl command gdb_selected_frame

 * Returns the address of the selected frame

 * frame.

 *

 * Arguments:

 *    None

 * Tcl Result:

 *    The currently selected frame's address

 */

static int

gdb_selected_frame (clientData, interp, objc, objv)

     ClientData clientData;

     Tcl_Interp *interp;

     int objc;

     Tcl_Obj *CONST objv[];

{

  char *frame;

  if (selected_frame == NULL)

    xasprintf (&frame, "%s","");

  else

    xasprintf (&frame, "0x%s", paddr_nz (FRAME_FP (selected_frame)));

  Tcl_SetStringObj (result_ptr->obj_ptr, frame, -1);

  free(frame);

  return TCL_OK;

}

/* 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;

    }

  if (target_has_stack)

    {

      gdb_result r;

      struct frame_info *top;

      struct frame_info *fi;

      /* Find the outermost frame */

      r  = GDB_get_current_frame (&fi);

      if (r != GDB_OK)

        return TCL_ERROR;

      while (fi != NULL)

        {

          top = fi;

          r = GDB_get_prev_frame (fi, &fi);

          if (r != GDB_OK)

            fi = NULL;

        }

      /* top now points to the top (outermost frame) of the

         stack, so point it to the requested start */

      start = -start;

      r = GDB_find_relative_frame (top, &start, &top);

      result_ptr->obj_ptr = Tcl_NewListObj (0, NULL);

      if (r != GDB_OK)

        return TCL_OK;

      /* 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);

              r = GDB_get_next_frame (fi, &fi);

              if (r != GDB_OK)

                break;

            }

        }

    }

  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 (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)

    {

      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]);

    }

}