gdb/gdbtk/generic/gdbtk-stack.c

   1 /* Tcl/Tk command definitions for Insight - Stack.
   2    Copyright (C) 2001, 2002, 2003 Free Software Foundation, Inc.
   3
   4    This file is part of GDB.
   5
   6    This program is free software; you can redistribute it and/or modify
   7    it under the terms of the GNU General Public License as published by
   8    the Free Software Foundation; either version 2 of the License, or
   9    (at your option) any later version.
  10
  11    This program is distributed in the hope that it will be useful,
  12    but WITHOUT ANY WARRANTY; without even the implied warranty of
  13    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14    GNU General Public License for more details.
  15
  16    You should have received a copy of the GNU General Public License
  17    along with this program; if not, write to the Free Software
  18    Foundation, Inc., 51 Franklin Street, Fifth Floor,
  19    Boston, MA 02110-1301, USA.  */
  20
  21 #include "defs.h"
  22 #include "target.h"
  23 #include "breakpoint.h"
  24 #include "linespec.h"
  25 #include "block.h"
  26 #include "dictionary.h"
  27
  28 #include <tcl.h>
  29 #include "gdbtk.h"
  30 #include "gdbtk-cmds.h"
  31 #include "gdbtk-wrapper.h"
  32
  33 static int gdb_block_vars (ClientData clientData,
  34                            Tcl_Interp * interp, int objc,
  35                            Tcl_Obj * CONST objv[]);
  36 static int gdb_get_args_command (ClientData, Tcl_Interp *, int,
  37                                  Tcl_Obj * CONST objv[]);
  38 static int gdb_get_blocks (ClientData clientData,
  39                            Tcl_Interp * interp, int objc,
  40                            Tcl_Obj * CONST objv[]);
  41 static int gdb_get_locals_command (ClientData, Tcl_Interp *, int,
  42                                    Tcl_Obj * CONST objv[]);
  43 static int gdb_get_vars_command (ClientData, Tcl_Interp *, int,
  44                                  Tcl_Obj * CONST objv[]);
  45 static int gdb_selected_block (ClientData clientData,
  46                                Tcl_Interp * interp, int argc,
  47                                Tcl_Obj * CONST objv[]);
  48 static int gdb_selected_frame (ClientData clientData,
  49                                Tcl_Interp * interp, int argc,
  50                                Tcl_Obj * CONST objv[]);
  51 static int gdb_stack (ClientData, Tcl_Interp *, int, Tcl_Obj * CONST[]);
  52 static void get_frame_name (Tcl_Interp *interp, Tcl_Obj *list,
  53                             struct frame_info *fi);
  54
  55 int
  56 Gdbtk_Stack_Init (Tcl_Interp *interp)
  57 {
  58   Tcl_CreateObjCommand (interp, "gdb_block_variables", gdbtk_call_wrapper,
  59                         gdb_block_vars, NULL);
  60   Tcl_CreateObjCommand (interp, "gdb_get_blocks", gdbtk_call_wrapper,
  61                         gdb_get_blocks, NULL);
  62   Tcl_CreateObjCommand (interp, "gdb_get_args", gdbtk_call_wrapper,
  63                         gdb_get_args_command, NULL);
  64   Tcl_CreateObjCommand (interp, "gdb_get_locals", gdbtk_call_wrapper,
  65                         gdb_get_locals_command, NULL);
  66   Tcl_CreateObjCommand (interp, "gdb_selected_block", gdbtk_call_wrapper,
  67                         gdb_selected_block, NULL);
  68   Tcl_CreateObjCommand (interp, "gdb_selected_frame", gdbtk_call_wrapper,
  69                         gdb_selected_frame, NULL);
  70   Tcl_CreateObjCommand (interp, "gdb_stack", gdbtk_call_wrapper, gdb_stack, NULL);
  71
  72   return TCL_OK;
  73 }
  74
  75 /* This implements the tcl command gdb_block_vars.
  76  *
  77  * Returns all variables valid in the specified block.
  78  *
  79  * Arguments:
  80  *    The start and end addresses which identify the block.
  81  * Tcl Result:
  82  *    All variables defined in the given block.
  83  */
  84 static int
  85 gdb_block_vars (ClientData clientData, Tcl_Interp *interp,
  86                 int objc, Tcl_Obj *CONST objv[])
  87 {
  88   struct block *block;
  89   struct dict_iterator iter;
  90   struct symbol *sym;
  91   CORE_ADDR start, end;
  92
  93   if (objc < 3)
  94     {
  95       Tcl_WrongNumArgs (interp, 1, objv, "startAddr endAddr");
  96       return TCL_ERROR;
  97     }
  98
  99   Tcl_SetListObj (result_ptr->obj_ptr, 0, NULL);
 100   if (!target_has_registers)
 101     return TCL_OK;
 102
 103   start = string_to_core_addr (Tcl_GetStringFromObj (objv[1], NULL));
 104   end   = string_to_core_addr (Tcl_GetStringFromObj (objv[2], NULL));
 105
 106   block = get_frame_block (get_selected_frame (NULL), 0);
 107
 108   while (block != 0)
 109     {
 110       if (BLOCK_START (block) == start && BLOCK_END (block) == end)
 111         {
 112           ALL_BLOCK_SYMBOLS (block, iter, sym)
 113             {
 114               switch (SYMBOL_CLASS (sym))
 115                 {
 116                 case LOC_ARG:             /* argument              */
 117                 case LOC_REF_ARG:         /* reference arg         */
 118                 case LOC_REGPARM:         /* register arg          */
 119                 case LOC_REGPARM_ADDR:    /* indirect register arg */
 120                 case LOC_LOCAL_ARG:       /* stack arg             */
 121                 case LOC_BASEREG_ARG:     /* basereg arg           */
 122                 case LOC_LOCAL:           /* stack local           */
 123                 case LOC_BASEREG:         /* basereg local         */
 124                 case LOC_STATIC:          /* static                */
 125                 case LOC_REGISTER:        /* register              */
 126                 case LOC_COMPUTED:        /* computed location     */
 127                 case LOC_COMPUTED_ARG:    /* computed location arg */
 128                   Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr,
 129                                             Tcl_NewStringObj (DEPRECATED_SYMBOL_NAME (sym),
 130                                                               -1));
 131                   break;
 132
 133                 default:
 134                   break;
 135                 }
 136             }
 137
 138           return TCL_OK;
 139         }
 140       else if (BLOCK_FUNCTION (block))
 141         break;
 142       else
 143         block = BLOCK_SUPERBLOCK (block);
 144     }
 145
 146   return TCL_OK;
 147 }
 148
 149 /* This implements the tcl command gdb_get_blocks
 150  *
 151  * Returns the start and end addresses for all blocks in
 152  * the selected frame.
 153  *
 154  * Arguments:
 155  *    None
 156  * Tcl Result:
 157  *    A list of all valid blocks in the selected_frame.
 158  */
 159 static int
 160 gdb_get_blocks (ClientData clientData, Tcl_Interp *interp,
 161                 int objc, Tcl_Obj *CONST objv[])
 162 {
 163   struct block *block;
 164   struct dict_iterator iter;
 165   int junk;
 166   struct symbol *sym;
 167   CORE_ADDR pc;
 168
 169   Tcl_SetListObj (result_ptr->obj_ptr, 0, NULL);
 170
 171   if (target_has_registers)
 172     {
 173       struct frame_info *frame = get_selected_frame (NULL);
 174
 175       block = get_frame_block (frame, 0);
 176       pc = get_frame_pc (frame);
 177       while (block != 0)
 178         {
 179           junk = 0;
 180           ALL_BLOCK_SYMBOLS (block, iter, sym)
 181             {
 182               switch (SYMBOL_CLASS (sym))
 183                 {
 184                 default:
 185                 case LOC_UNDEF:           /* catches errors        */
 186                 case LOC_CONST:           /* constant              */
 187                 case LOC_TYPEDEF:         /* local typedef         */
 188                 case LOC_LABEL:           /* local label           */
 189                 case LOC_BLOCK:           /* local function        */
 190                 case LOC_CONST_BYTES:     /* loc. byte seq.        */
 191                 case LOC_UNRESOLVED:      /* unresolved static     */
 192                 case LOC_OPTIMIZED_OUT:   /* optimized out         */
 193                   junk = 1;
 194                   break;
 195
 196                 case LOC_ARG:             /* argument              */
 197                 case LOC_REF_ARG:         /* reference arg         */
 198                 case LOC_REGPARM:         /* register arg          */
 199                 case LOC_REGPARM_ADDR:    /* indirect register arg */
 200                 case LOC_LOCAL_ARG:       /* stack arg             */
 201                 case LOC_BASEREG_ARG:     /* basereg arg           */
 202                 case LOC_COMPUTED_ARG:    /* computed location arg */
 203
 204                 case LOC_LOCAL:           /* stack local           */
 205                 case LOC_BASEREG:         /* basereg local         */
 206                 case LOC_STATIC:          /* static                */
 207                 case LOC_REGISTER:        /* register              */
 208                 case LOC_COMPUTED:        /* computed location     */
 209                   junk = 0;
 210                   break;
 211                 }
 212             }
 213
 214           /* If we found a block with locals in it, add it to the list.
 215              Note that the ranges of start and end address for blocks
 216              are exclusive, so double-check against the PC */
 217
 218           if (!junk && pc < BLOCK_END (block))
 219             {
 220               char *addr;
 221
 222               Tcl_Obj *elt = Tcl_NewListObj (0, NULL);
 223               xasprintf (&addr, "0x%s", paddr_nz (BLOCK_START (block)));
 224               Tcl_ListObjAppendElement (interp, elt,
 225                                         Tcl_NewStringObj (addr, -1));
 226               free(addr);
 227               xasprintf (&addr, "0x%s", paddr_nz (BLOCK_END (block)));
 228               Tcl_ListObjAppendElement (interp, elt,
 229                                         Tcl_NewStringObj (addr, -1));
 230               Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr, elt);
 231               free(addr);
 232             }
 233
 234           if (BLOCK_FUNCTION (block))
 235             break;
 236           else
 237             block = BLOCK_SUPERBLOCK (block);
 238         }
 239     }
 240
 241   return TCL_OK;
 242 }
 243
 244 /* gdb_get_args -
 245  * This and gdb_get_locals just call gdb_get_vars_command with the right
 246  * value of clientData.  We can't use the client data in the definition
 247  * of the command, because the call wrapper uses this instead...
 248  */
 249 static int
 250 gdb_get_args_command (ClientData clientData, Tcl_Interp *interp,
 251                       int objc, Tcl_Obj *CONST objv[])
 252 {
 253   return gdb_get_vars_command ((ClientData) 1, interp, objc, objv);
 254 }
 255
 256
 257 static int
 258 gdb_get_locals_command (ClientData clientData, Tcl_Interp *interp,
 259                         int objc, Tcl_Obj *CONST objv[])
 260 {
 261   return gdb_get_vars_command ((ClientData) 0, interp, objc, objv);
 262 }
 263
 264 /* This implements the tcl commands "gdb_get_locals" and "gdb_get_args"
 265
 266 * This function sets the Tcl interpreter's result to a list of variable names
 267 * depending on clientData. If clientData is one, the result is a list of
 268 * arguments; zero returns a list of locals -- all relative to the block
 269 * specified as an argument to the command. Valid commands include
 270 * anything decode_line_1 can handle (like "main.c:2", "*0x02020202",
 271 * and "main").
 272 *
 273 * Tcl Arguments:
 274 *   linespec - the linespec defining the scope of the lookup. Empty string
 275 *              to use the current block in the innermost frame.
 276 * Tcl Result:
 277 *   A list of the locals or args
 278 */
 279 static int
 280 gdb_get_vars_command (ClientData clientData, Tcl_Interp *interp,
 281                       int objc, Tcl_Obj *CONST objv[])
 282 {
 283   struct symtabs_and_lines sals;
 284   struct symbol *sym;
 285   struct block *block;
 286   char **canonical, *args;
 287   struct dict_iterator iter;
 288   int i, arguments;
 289
 290   if (objc > 2)
 291     {
 292       Tcl_WrongNumArgs (interp, 1, objv,
 293                         "[function:line|function|line|*addr]");
 294       return TCL_ERROR;
 295     }
 296
 297   arguments = (int) clientData;
 298
 299   /* Initialize the result pointer to an empty list. */
 300
 301   Tcl_SetListObj (result_ptr->obj_ptr, 0, NULL);
 302
 303   if (objc == 2)
 304     {
 305       args = Tcl_GetStringFromObj (objv[1], NULL);
 306       sals = decode_line_1 (&args, 1, NULL, 0, &canonical, NULL);
 307       if (sals.nelts == 0)
 308         {
 309           gdbtk_set_result (interp, "error decoding line");
 310           return TCL_ERROR;
 311         }
 312
 313       /* Resolve all line numbers to PC's */
 314       for (i = 0; i < sals.nelts; i++)
 315         resolve_sal_pc (&sals.sals[i]);
 316
 317       block = block_for_pc (sals.sals[0].pc);
 318     }
 319   else
 320     {
 321       /* Specified currently selected frame */
 322       if (!target_has_registers)
 323         return TCL_OK;
 324
 325       block = get_frame_block (get_selected_frame (NULL), 0);
 326     }
 327
 328   while (block != 0)
 329     {
 330       ALL_BLOCK_SYMBOLS (block, iter, sym)
 331         {
 332           switch (SYMBOL_CLASS (sym))
 333             {
 334             default:
 335             case LOC_UNDEF:     /* catches errors        */
 336             case LOC_CONST:     /* constant              */
 337             case LOC_TYPEDEF:   /* local typedef         */
 338             case LOC_LABEL:     /* local label           */
 339             case LOC_BLOCK:     /* local function        */
 340             case LOC_CONST_BYTES:       /* loc. byte seq.        */
 341             case LOC_UNRESOLVED:        /* unresolved static     */
 342             case LOC_OPTIMIZED_OUT:     /* optimized out         */
 343               break;
 344             case LOC_ARG:       /* argument              */
 345             case LOC_REF_ARG:   /* reference arg         */
 346             case LOC_REGPARM:   /* register arg          */
 347             case LOC_REGPARM_ADDR:      /* indirect register arg */
 348             case LOC_LOCAL_ARG: /* stack arg             */
 349             case LOC_BASEREG_ARG:       /* basereg arg           */
 350             case LOC_COMPUTED_ARG:      /* computed location arg */
 351               if (arguments)
 352                 Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr,
 353                                           Tcl_NewStringObj (DEPRECATED_SYMBOL_NAME (sym), -1));
 354               break;
 355             case LOC_LOCAL:     /* stack local           */
 356             case LOC_BASEREG:   /* basereg local         */
 357             case LOC_STATIC:    /* static                */
 358             case LOC_REGISTER:  /* register              */
 359             case LOC_COMPUTED:  /* computed location     */
 360               if (!arguments)
 361                 Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr,
 362                                           Tcl_NewStringObj (DEPRECATED_SYMBOL_NAME (sym), -1));
 363               break;
 364             }
 365         }
 366       if (BLOCK_FUNCTION (block))
 367         break;
 368       else
 369         block = BLOCK_SUPERBLOCK (block);
 370     }
 371
 372   return TCL_OK;
 373 }
 374
 375 /* This implements the tcl command gdb_selected_block
 376  *
 377  * Returns the start and end addresses of the innermost
 378  * block in the selected frame.
 379  *
 380  * Arguments:
 381  *    None
 382  * Tcl Result:
 383  *    The currently selected block's start and end addresses
 384  */
 385 static int
 386 gdb_selected_block (ClientData clientData, Tcl_Interp *interp,
 387                     int objc, Tcl_Obj *CONST objv[])
 388 {
 389   char *start = NULL;
 390   char *end   = NULL;
 391
 392   if (!target_has_registers)
 393     {
 394       xasprintf (&start, "%s", "");
 395       xasprintf (&end, "%s", "");
 396     }
 397   else
 398     {
 399       struct block *block;
 400       block = get_frame_block (get_selected_frame (NULL), 0);
 401       xasprintf (&start, "0x%s", paddr_nz (BLOCK_START (block)));
 402       xasprintf (&end, "0x%s", paddr_nz (BLOCK_END (block)));
 403     }
 404
 405   Tcl_SetListObj (result_ptr->obj_ptr, 0, NULL);
 406   Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr,
 407                             Tcl_NewStringObj (start, -1));
 408   Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr,
 409                             Tcl_NewStringObj (end, -1));
 410
 411   free(start);
 412   free(end);
 413   return TCL_OK;
 414 }
 415
 416 /* This implements the tcl command gdb_selected_frame
 417
 418 * Returns the address of the selected frame
 419 * frame.
 420 *
 421 * Arguments:
 422 *    None
 423 * Tcl Result:
 424 *    The currently selected frame's address
 425 */
 426 static int
 427 gdb_selected_frame (ClientData clientData, Tcl_Interp *interp,
 428                     int objc, Tcl_Obj *CONST objv[])
 429 {
 430   char *frame;
 431
 432   if (!target_has_registers)
 433     xasprintf (&frame, "%s","");
 434   else
 435     /* FIXME: cagney/2002-11-19: This should be using get_frame_id()
 436        to identify the frame and *NOT* get_frame_base().  */
 437     xasprintf (&frame, "0x%s",
 438                paddr_nz (get_frame_base (get_selected_frame (NULL))));
 439
 440   Tcl_SetStringObj (result_ptr->obj_ptr, frame, -1);
 441
 442   free(frame);
 443   return TCL_OK;
 444 }
 445
 446 /* This implements the tcl command gdb_stack.
 447  * It builds up a list of stack frames.
 448  *
 449  * Tcl Arguments:
 450  *    start  - starting stack frame
 451  *    count - number of frames to inspect
 452  * Tcl Result:
 453  *    A list of function names
 454  */
 455 static int
 456 gdb_stack (ClientData clientData, Tcl_Interp *interp,
 457            int objc, Tcl_Obj *CONST objv[])
 458 {
 459   int start, count;
 460
 461   if (objc < 3)
 462     {
 463       Tcl_WrongNumArgs (interp, 1, objv, "start count");
 464       return TCL_ERROR;
 465     }
 466
 467   if (Tcl_GetIntFromObj (NULL, objv[1], &start))
 468     {
 469       result_ptr->flags |= GDBTK_IN_TCL_RESULT;
 470       return TCL_ERROR;
 471     }
 472   if (Tcl_GetIntFromObj (NULL, objv[2], &count))
 473     {
 474       result_ptr->flags |= GDBTK_IN_TCL_RESULT;
 475       return TCL_ERROR;
 476     }
 477
 478   if (target_has_stack)
 479     {
 480       gdb_result r;
 481       struct frame_info *top;
 482       struct frame_info *fi;
 483
 484       /* Find the outermost frame */
 485       r  = GDB_get_current_frame (&fi);
 486       if (r != GDB_OK)
 487         return TCL_ERROR;
 488
 489       while (fi != NULL)
 490         {
 491           top = fi;
 492           r = GDB_get_prev_frame (fi, &fi);
 493           if (r != GDB_OK)
 494             fi = NULL;
 495         }
 496
 497       /* top now points to the top (outermost frame) of the
 498          stack, so point it to the requested start */
 499       start = -start;
 500       r = GDB_find_relative_frame (top, &start, &top);
 501
 502       result_ptr->obj_ptr = Tcl_NewListObj (0, NULL);
 503       if (r != GDB_OK)
 504         return TCL_OK;
 505
 506       /* If start != 0, then we have asked to start outputting
 507          frames beyond the innermost stack frame */
 508       if (start == 0)
 509         {
 510           fi = top;
 511           while (fi && count--)
 512             {
 513               get_frame_name (interp, result_ptr->obj_ptr, fi);
 514               r = GDB_get_next_frame (fi, &fi);
 515               if (r != GDB_OK)
 516                 break;
 517             }
 518         }
 519     }
 520
 521   return TCL_OK;
 522 }
 523
 524 /* A helper function for get_stack which adds information about
 525  * the stack frame FI to the caller's LIST.
 526  *
 527  * This is stolen from print_frame_info in stack.c.
 528  */
 529 static void
 530 get_frame_name (Tcl_Interp *interp, Tcl_Obj *list, struct frame_info *fi)
 531 {
 532   struct symtab_and_line sal;
 533   struct symbol *func = NULL;
 534   register char *funname = 0;
 535   enum language funlang = language_unknown;
 536   Tcl_Obj *objv[1];
 537
 538   if (get_frame_type (fi) == DUMMY_FRAME)
 539     {
 540       objv[0] = Tcl_NewStringObj ("<function called from gdb>\n", -1);
 541       Tcl_ListObjAppendElement (interp, list, objv[0]);
 542       return;
 543     }
 544   if ((get_frame_type (fi) == SIGTRAMP_FRAME))
 545     {
 546       objv[0] = Tcl_NewStringObj ("<signal handler called>\n", -1);
 547       Tcl_ListObjAppendElement (interp, list, objv[0]);
 548       return;
 549     }
 550
 551   sal =
 552     find_pc_line (get_frame_pc (fi),
 553                   get_next_frame (fi) != NULL
 554                   && !(get_frame_type (fi) == SIGTRAMP_FRAME)
 555                   && !(get_frame_type (fi) == DUMMY_FRAME));
 556
 557   func = find_pc_function (get_frame_pc (fi));
 558   if (func)
 559     {
 560       struct minimal_symbol *msymbol = lookup_minimal_symbol_by_pc (get_frame_pc (fi));
 561       if (msymbol != NULL
 562           && (SYMBOL_VALUE_ADDRESS (msymbol)
 563               > BLOCK_START (SYMBOL_BLOCK_VALUE (func))))
 564         {
 565           func = 0;
 566           funname = GDBTK_SYMBOL_SOURCE_NAME (msymbol);
 567           funlang = SYMBOL_LANGUAGE (msymbol);
 568         }
 569       else
 570         {
 571           funname = GDBTK_SYMBOL_SOURCE_NAME (func);
 572           funlang = SYMBOL_LANGUAGE (func);
 573         }
 574     }
 575   else
 576     {
 577       struct minimal_symbol *msymbol = lookup_minimal_symbol_by_pc (get_frame_pc (fi));
 578       if (msymbol != NULL)
 579         {
 580           funname = GDBTK_SYMBOL_SOURCE_NAME (msymbol);
 581           funlang = SYMBOL_LANGUAGE (msymbol);
 582         }
 583     }
 584
 585   if (sal.symtab)
 586     {
 587       objv[0] = Tcl_NewStringObj (funname, -1);
 588       Tcl_ListObjAppendElement (interp, list, objv[0]);
 589     }
 590   else
 591     {
 592 #if 0
 593       /* we have no convenient way to deal with this yet... */
 594       if (fi->pc != sal.pc || !sal.symtab)
 595         {
 596           deprecated_print_address_numeric (fi->pc, 1, gdb_stdout);
 597           printf_filtered (" in ");
 598         }
 599       printf_symbol_filtered (gdb_stdout, funname ? funname : "??", funlang,
 600                               DMGL_ANSI);
 601 #endif
 602       objv[0] = Tcl_NewStringObj (funname != NULL ? funname : "??", -1);
 603 #ifdef PC_LOAD_SEGMENT
 604       /* If we couldn't print out function name but if can figure out what
 605          load segment this pc value is from, at least print out some info
 606          about its load segment. */
 607       if (!funname)
 608         {
 609           Tcl_AppendStringsToObj (objv[0], " from ", PC_LOAD_SEGMENT (fi->pc),
 610                                   (char *) NULL);
 611         }
 612 #endif
 613 #ifdef PC_SOLIB
 614       if (!funname)
 615         {
 616           char *lib = PC_SOLIB (get_frame_pc (fi));
 617           if (lib)
 618             {
 619               Tcl_AppendStringsToObj (objv[0], " from ", lib, (char *) NULL);
 620             }
 621         }
 622 #endif
 623       Tcl_ListObjAppendElement (interp, list, objv[0]);
 624     }
 625 }