gdb/guile/scm-symbol.c

   1 /* Scheme interface to symbols.
   2
   3    Copyright (C) 2008-2015 Free Software Foundation, Inc.
   4
   5    This file is part of GDB.
   6
   7    This program is free software; you can redistribute it and/or modify
   8    it under the terms of the GNU General Public License as published by
   9    the Free Software Foundation; either version 3 of the License, or
  10    (at your option) any later version.
  11
  12    This program is distributed in the hope that it will be useful,
  13    but WITHOUT ANY WARRANTY; without even the implied warranty of
  14    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15    GNU General Public License for more details.
  16
  17    You should have received a copy of the GNU General Public License
  18    along with this program.  If not, see <http://www.gnu.org/licenses/>.  */
  19
  20 /* See README file in this directory for implementation notes, coding
  21    conventions, et.al.  */
  22
  23 #include "defs.h"
  24 #include "block.h"
  25 #include "frame.h"
  26 #include "symtab.h"
  27 #include "objfiles.h"
  28 #include "value.h"
  29 #include "guile-internal.h"
  30
  31 /* The <gdb:symbol> smob.  */
  32
  33 typedef struct
  34 {
  35   /* This always appears first.  */
  36   eqable_gdb_smob base;
  37
  38   /* The GDB symbol structure this smob is wrapping.  */
  39   struct symbol *symbol;
  40 } symbol_smob;
  41
  42 static const char symbol_smob_name[] = "gdb:symbol";
  43
  44 /* The tag Guile knows the symbol smob by.  */
  45 static scm_t_bits symbol_smob_tag;
  46
  47 /* Keywords used in argument passing.  */
  48 static SCM block_keyword;
  49 static SCM domain_keyword;
  50 static SCM frame_keyword;
  51
  52 static const struct objfile_data *syscm_objfile_data_key;
  53 static struct gdbarch_data *syscm_gdbarch_data_key;
  54
  55 struct syscm_gdbarch_data
  56 {
  57   /* Hash table to implement eqable gdbarch symbols.  */
  58   htab_t htab;
  59 };
  60 \f
  61 /* Administrivia for symbol smobs.  */
  62
  63 /* Helper function to hash a symbol_smob.  */
  64
  65 static hashval_t
  66 syscm_hash_symbol_smob (const void *p)
  67 {
  68   const symbol_smob *s_smob = (const symbol_smob *) p;
  69
  70   return htab_hash_pointer (s_smob->symbol);
  71 }
  72
  73 /* Helper function to compute equality of symbol_smobs.  */
  74
  75 static int
  76 syscm_eq_symbol_smob (const void *ap, const void *bp)
  77 {
  78   const symbol_smob *a = (const symbol_smob *) ap;
  79   const symbol_smob *b = (const symbol_smob *) bp;
  80
  81   return (a->symbol == b->symbol
  82           && a->symbol != NULL);
  83 }
  84
  85 static void *
  86 syscm_init_arch_symbols (struct gdbarch *gdbarch)
  87 {
  88   struct syscm_gdbarch_data *data
  89     = GDBARCH_OBSTACK_ZALLOC (gdbarch, struct syscm_gdbarch_data);
  90
  91   data->htab = gdbscm_create_eqable_gsmob_ptr_map (syscm_hash_symbol_smob,
  92                                                    syscm_eq_symbol_smob);
  93   return data;
  94 }
  95
  96 /* Return the struct symbol pointer -> SCM mapping table.
  97    It is created if necessary.  */
  98
  99 static htab_t
 100 syscm_get_symbol_map (struct symbol *symbol)
 101 {
 102   htab_t htab;
 103
 104   if (SYMBOL_OBJFILE_OWNED (symbol))
 105     {
 106       struct objfile *objfile = symbol_objfile (symbol);
 107
 108       htab = (htab_t) objfile_data (objfile, syscm_objfile_data_key);
 109       if (htab == NULL)
 110         {
 111           htab = gdbscm_create_eqable_gsmob_ptr_map (syscm_hash_symbol_smob,
 112                                                      syscm_eq_symbol_smob);
 113           set_objfile_data (objfile, syscm_objfile_data_key, htab);
 114         }
 115     }
 116   else
 117     {
 118       struct gdbarch *gdbarch = symbol_arch (symbol);
 119       struct syscm_gdbarch_data *data
 120         = (struct syscm_gdbarch_data *) gdbarch_data (gdbarch,
 121                                                       syscm_gdbarch_data_key);
 122
 123       htab = data->htab;
 124     }
 125
 126   return htab;
 127 }
 128
 129 /* The smob "free" function for <gdb:symbol>.  */
 130
 131 static size_t
 132 syscm_free_symbol_smob (SCM self)
 133 {
 134   symbol_smob *s_smob = (symbol_smob *) SCM_SMOB_DATA (self);
 135
 136   if (s_smob->symbol != NULL)
 137     {
 138       htab_t htab = syscm_get_symbol_map (s_smob->symbol);
 139
 140       gdbscm_clear_eqable_gsmob_ptr_slot (htab, &s_smob->base);
 141     }
 142
 143   /* Not necessary, done to catch bugs.  */
 144   s_smob->symbol = NULL;
 145
 146   return 0;
 147 }
 148
 149 /* The smob "print" function for <gdb:symbol>.  */
 150
 151 static int
 152 syscm_print_symbol_smob (SCM self, SCM port, scm_print_state *pstate)
 153 {
 154   symbol_smob *s_smob = (symbol_smob *) SCM_SMOB_DATA (self);
 155
 156   if (pstate->writingp)
 157     gdbscm_printf (port, "#<%s ", symbol_smob_name);
 158   gdbscm_printf (port, "%s",
 159                  s_smob->symbol != NULL
 160                  ? SYMBOL_PRINT_NAME (s_smob->symbol)
 161                  : "<invalid>");
 162   if (pstate->writingp)
 163     scm_puts (">", port);
 164
 165   scm_remember_upto_here_1 (self);
 166
 167   /* Non-zero means success.  */
 168   return 1;
 169 }
 170
 171 /* Low level routine to create a <gdb:symbol> object.  */
 172
 173 static SCM
 174 syscm_make_symbol_smob (void)
 175 {
 176   symbol_smob *s_smob = (symbol_smob *)
 177     scm_gc_malloc (sizeof (symbol_smob), symbol_smob_name);
 178   SCM s_scm;
 179
 180   s_smob->symbol = NULL;
 181   s_scm = scm_new_smob (symbol_smob_tag, (scm_t_bits) s_smob);
 182   gdbscm_init_eqable_gsmob (&s_smob->base, s_scm);
 183
 184   return s_scm;
 185 }
 186
 187 /* Return non-zero if SCM is a symbol smob.  */
 188
 189 int
 190 syscm_is_symbol (SCM scm)
 191 {
 192   return SCM_SMOB_PREDICATE (symbol_smob_tag, scm);
 193 }
 194
 195 /* (symbol? object) -> boolean */
 196
 197 static SCM
 198 gdbscm_symbol_p (SCM scm)
 199 {
 200   return scm_from_bool (syscm_is_symbol (scm));
 201 }
 202
 203 /* Return the existing object that encapsulates SYMBOL, or create a new
 204    <gdb:symbol> object.  */
 205
 206 SCM
 207 syscm_scm_from_symbol (struct symbol *symbol)
 208 {
 209   htab_t htab;
 210   eqable_gdb_smob **slot;
 211   symbol_smob *s_smob, s_smob_for_lookup;
 212   SCM s_scm;
 213
 214   /* If we've already created a gsmob for this symbol, return it.
 215      This makes symbols eq?-able.  */
 216   htab = syscm_get_symbol_map (symbol);
 217   s_smob_for_lookup.symbol = symbol;
 218   slot = gdbscm_find_eqable_gsmob_ptr_slot (htab, &s_smob_for_lookup.base);
 219   if (*slot != NULL)
 220     return (*slot)->containing_scm;
 221
 222   s_scm = syscm_make_symbol_smob ();
 223   s_smob = (symbol_smob *) SCM_SMOB_DATA (s_scm);
 224   s_smob->symbol = symbol;
 225   gdbscm_fill_eqable_gsmob_ptr_slot (slot, &s_smob->base);
 226
 227   return s_scm;
 228 }
 229
 230 /* Returns the <gdb:symbol> object in SELF.
 231    Throws an exception if SELF is not a <gdb:symbol> object.  */
 232
 233 static SCM
 234 syscm_get_symbol_arg_unsafe (SCM self, int arg_pos, const char *func_name)
 235 {
 236   SCM_ASSERT_TYPE (syscm_is_symbol (self), self, arg_pos, func_name,
 237                    symbol_smob_name);
 238
 239   return self;
 240 }
 241
 242 /* Returns a pointer to the symbol smob of SELF.
 243    Throws an exception if SELF is not a <gdb:symbol> object.  */
 244
 245 static symbol_smob *
 246 syscm_get_symbol_smob_arg_unsafe (SCM self, int arg_pos, const char *func_name)
 247 {
 248   SCM s_scm = syscm_get_symbol_arg_unsafe (self, arg_pos, func_name);
 249   symbol_smob *s_smob = (symbol_smob *) SCM_SMOB_DATA (s_scm);
 250
 251   return s_smob;
 252 }
 253
 254 /* Return non-zero if symbol S_SMOB is valid.  */
 255
 256 static int
 257 syscm_is_valid (symbol_smob *s_smob)
 258 {
 259   return s_smob->symbol != NULL;
 260 }
 261
 262 /* Throw a Scheme error if SELF is not a valid symbol smob.
 263    Otherwise return a pointer to the symbol smob.  */
 264
 265 static symbol_smob *
 266 syscm_get_valid_symbol_smob_arg_unsafe (SCM self, int arg_pos,
 267                                         const char *func_name)
 268 {
 269   symbol_smob *s_smob
 270     = syscm_get_symbol_smob_arg_unsafe (self, arg_pos, func_name);
 271
 272   if (!syscm_is_valid (s_smob))
 273     {
 274       gdbscm_invalid_object_error (func_name, arg_pos, self,
 275                                    _("<gdb:symbol>"));
 276     }
 277
 278   return s_smob;
 279 }
 280
 281 /* Throw a Scheme error if SELF is not a valid symbol smob.
 282    Otherwise return a pointer to the symbol struct.  */
 283
 284 struct symbol *
 285 syscm_get_valid_symbol_arg_unsafe (SCM self, int arg_pos,
 286                                    const char *func_name)
 287 {
 288   symbol_smob *s_smob = syscm_get_valid_symbol_smob_arg_unsafe (self, arg_pos,
 289                                                                 func_name);
 290
 291   return s_smob->symbol;
 292 }
 293
 294 /* Helper function for syscm_del_objfile_symbols to mark the symbol
 295    as invalid.  */
 296
 297 static int
 298 syscm_mark_symbol_invalid (void **slot, void *info)
 299 {
 300   symbol_smob *s_smob = (symbol_smob *) *slot;
 301
 302   s_smob->symbol = NULL;
 303   return 1;
 304 }
 305
 306 /* This function is called when an objfile is about to be freed.
 307    Invalidate the symbol as further actions on the symbol would result
 308    in bad data.  All access to s_smob->symbol should be gated by
 309    syscm_get_valid_symbol_smob_arg_unsafe which will raise an exception on
 310    invalid symbols.  */
 311
 312 static void
 313 syscm_del_objfile_symbols (struct objfile *objfile, void *datum)
 314 {
 315   htab_t htab = (htab_t) datum;
 316
 317   if (htab != NULL)
 318     {
 319       htab_traverse_noresize (htab, syscm_mark_symbol_invalid, NULL);
 320       htab_delete (htab);
 321     }
 322 }
 323 \f
 324 /* Symbol methods.  */
 325
 326 /* (symbol-valid? <gdb:symbol>) -> boolean
 327    Returns #t if SELF still exists in GDB.  */
 328
 329 static SCM
 330 gdbscm_symbol_valid_p (SCM self)
 331 {
 332   symbol_smob *s_smob
 333     = syscm_get_symbol_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 334
 335   return scm_from_bool (syscm_is_valid (s_smob));
 336 }
 337
 338 /* (symbol-type <gdb:symbol>) -> <gdb:type>
 339    Return the type of SELF, or #f if SELF has no type.  */
 340
 341 static SCM
 342 gdbscm_symbol_type (SCM self)
 343 {
 344   symbol_smob *s_smob
 345     = syscm_get_valid_symbol_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 346   const struct symbol *symbol = s_smob->symbol;
 347
 348   if (SYMBOL_TYPE (symbol) == NULL)
 349     return SCM_BOOL_F;
 350
 351   return tyscm_scm_from_type (SYMBOL_TYPE (symbol));
 352 }
 353
 354 /* (symbol-symtab <gdb:symbol>) -> <gdb:symtab> | #f
 355    Return the symbol table of SELF.
 356    If SELF does not have a symtab (it is arch-owned) return #f.  */
 357
 358 static SCM
 359 gdbscm_symbol_symtab (SCM self)
 360 {
 361   symbol_smob *s_smob
 362     = syscm_get_valid_symbol_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 363   const struct symbol *symbol = s_smob->symbol;
 364
 365   if (!SYMBOL_OBJFILE_OWNED (symbol))
 366     return SCM_BOOL_F;
 367   return stscm_scm_from_symtab (symbol_symtab (symbol));
 368 }
 369
 370 /* (symbol-name <gdb:symbol>) -> string */
 371
 372 static SCM
 373 gdbscm_symbol_name (SCM self)
 374 {
 375   symbol_smob *s_smob
 376     = syscm_get_valid_symbol_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 377   const struct symbol *symbol = s_smob->symbol;
 378
 379   return gdbscm_scm_from_c_string (SYMBOL_NATURAL_NAME (symbol));
 380 }
 381
 382 /* (symbol-linkage-name <gdb:symbol>) -> string */
 383
 384 static SCM
 385 gdbscm_symbol_linkage_name (SCM self)
 386 {
 387   symbol_smob *s_smob
 388     = syscm_get_valid_symbol_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 389   const struct symbol *symbol = s_smob->symbol;
 390
 391   return gdbscm_scm_from_c_string (SYMBOL_LINKAGE_NAME (symbol));
 392 }
 393
 394 /* (symbol-print-name <gdb:symbol>) -> string */
 395
 396 static SCM
 397 gdbscm_symbol_print_name (SCM self)
 398 {
 399   symbol_smob *s_smob
 400     = syscm_get_valid_symbol_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 401   const struct symbol *symbol = s_smob->symbol;
 402
 403   return gdbscm_scm_from_c_string (SYMBOL_PRINT_NAME (symbol));
 404 }
 405
 406 /* (symbol-addr-class <gdb:symbol>) -> integer */
 407
 408 static SCM
 409 gdbscm_symbol_addr_class (SCM self)
 410 {
 411   symbol_smob *s_smob
 412     = syscm_get_valid_symbol_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 413   const struct symbol *symbol = s_smob->symbol;
 414
 415   return scm_from_int (SYMBOL_CLASS (symbol));
 416 }
 417
 418 /* (symbol-argument? <gdb:symbol>) -> boolean */
 419
 420 static SCM
 421 gdbscm_symbol_argument_p (SCM self)
 422 {
 423   symbol_smob *s_smob
 424     = syscm_get_valid_symbol_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 425   const struct symbol *symbol = s_smob->symbol;
 426
 427   return scm_from_bool (SYMBOL_IS_ARGUMENT (symbol));
 428 }
 429
 430 /* (symbol-constant? <gdb:symbol>) -> boolean */
 431
 432 static SCM
 433 gdbscm_symbol_constant_p (SCM self)
 434 {
 435   symbol_smob *s_smob
 436     = syscm_get_valid_symbol_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 437   const struct symbol *symbol = s_smob->symbol;
 438   enum address_class theclass;
 439
 440   theclass = SYMBOL_CLASS (symbol);
 441
 442   return scm_from_bool (theclass == LOC_CONST || theclass == LOC_CONST_BYTES);
 443 }
 444
 445 /* (symbol-function? <gdb:symbol>) -> boolean */
 446
 447 static SCM
 448 gdbscm_symbol_function_p (SCM self)
 449 {
 450   symbol_smob *s_smob
 451     = syscm_get_valid_symbol_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 452   const struct symbol *symbol = s_smob->symbol;
 453   enum address_class theclass;
 454
 455   theclass = SYMBOL_CLASS (symbol);
 456
 457   return scm_from_bool (theclass == LOC_BLOCK);
 458 }
 459
 460 /* (symbol-variable? <gdb:symbol>) -> boolean */
 461
 462 static SCM
 463 gdbscm_symbol_variable_p (SCM self)
 464 {
 465   symbol_smob *s_smob
 466     = syscm_get_valid_symbol_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 467   const struct symbol *symbol = s_smob->symbol;
 468   enum address_class theclass;
 469
 470   theclass = SYMBOL_CLASS (symbol);
 471
 472   return scm_from_bool (!SYMBOL_IS_ARGUMENT (symbol)
 473                         && (theclass == LOC_LOCAL || theclass == LOC_REGISTER
 474                             || theclass == LOC_STATIC || theclass == LOC_COMPUTED
 475                             || theclass == LOC_OPTIMIZED_OUT));
 476 }
 477
 478 /* (symbol-needs-frame? <gdb:symbol>) -> boolean
 479    Return #t if the symbol needs a frame for evaluation.  */
 480
 481 static SCM
 482 gdbscm_symbol_needs_frame_p (SCM self)
 483 {
 484   symbol_smob *s_smob
 485     = syscm_get_valid_symbol_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 486   struct symbol *symbol = s_smob->symbol;
 487   int result = 0;
 488
 489   TRY
 490     {
 491       result = symbol_read_needs_frame (symbol);
 492     }
 493   CATCH (except, RETURN_MASK_ALL)
 494     {
 495       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 496     }
 497   END_CATCH
 498
 499   return scm_from_bool (result);
 500 }
 501
 502 /* (symbol-line <gdb:symbol>) -> integer
 503    Return the line number at which the symbol was defined.  */
 504
 505 static SCM
 506 gdbscm_symbol_line (SCM self)
 507 {
 508   symbol_smob *s_smob
 509     = syscm_get_valid_symbol_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 510   const struct symbol *symbol = s_smob->symbol;
 511
 512   return scm_from_int (SYMBOL_LINE (symbol));
 513 }
 514
 515 /* (symbol-value <gdb:symbol> [#:frame <gdb:frame>]) -> <gdb:value>
 516    Return the value of the symbol, or an error in various circumstances.  */
 517
 518 static SCM
 519 gdbscm_symbol_value (SCM self, SCM rest)
 520 {
 521   symbol_smob *s_smob
 522     = syscm_get_valid_symbol_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 523   struct symbol *symbol = s_smob->symbol;
 524   SCM keywords[] = { frame_keyword, SCM_BOOL_F };
 525   int frame_pos = -1;
 526   SCM frame_scm = SCM_BOOL_F;
 527   frame_smob *f_smob = NULL;
 528   struct frame_info *frame_info = NULL;
 529   struct value *value = NULL;
 530
 531   gdbscm_parse_function_args (FUNC_NAME, SCM_ARG2, keywords, "#O",
 532                               rest, &frame_pos, &frame_scm);
 533   if (!gdbscm_is_false (frame_scm))
 534     f_smob = frscm_get_frame_smob_arg_unsafe (frame_scm, frame_pos, FUNC_NAME);
 535
 536   if (SYMBOL_CLASS (symbol) == LOC_TYPEDEF)
 537     {
 538       gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, self,
 539                                  _("cannot get the value of a typedef"));
 540     }
 541
 542   TRY
 543     {
 544       if (f_smob != NULL)
 545         {
 546           frame_info = frscm_frame_smob_to_frame (f_smob);
 547           if (frame_info == NULL)
 548             error (_("Invalid frame"));
 549         }
 550
 551       if (symbol_read_needs_frame (symbol) && frame_info == NULL)
 552         error (_("Symbol requires a frame to compute its value"));
 553
 554       /* TODO: currently, we have no way to recover the block in which SYMBOL
 555          was found, so we have no block to pass to read_var_value.  This will
 556          yield an incorrect value when symbol is not local to FRAME_INFO (this
 557          can happen with nested functions).  */
 558       value = read_var_value (symbol, NULL, frame_info);
 559     }
 560   CATCH (except, RETURN_MASK_ALL)
 561     {
 562       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 563     }
 564   END_CATCH
 565
 566   return vlscm_scm_from_value (value);
 567 }
 568 \f
 569 /* (lookup-symbol name [#:block <gdb:block>] [#:domain domain])
 570      -> (<gdb:symbol> field-of-this?)
 571    The result is #f if the symbol is not found.
 572    See comment in lookup_symbol_in_language for field-of-this?.  */
 573
 574 static SCM
 575 gdbscm_lookup_symbol (SCM name_scm, SCM rest)
 576 {
 577   char *name;
 578   SCM keywords[] = { block_keyword, domain_keyword, SCM_BOOL_F };
 579   const struct block *block = NULL;
 580   SCM block_scm = SCM_BOOL_F;
 581   int domain = VAR_DOMAIN;
 582   int block_arg_pos = -1, domain_arg_pos = -1;
 583   struct field_of_this_result is_a_field_of_this;
 584   struct symbol *symbol = NULL;
 585   struct cleanup *cleanups;
 586   struct gdb_exception except = exception_none;
 587
 588   gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, keywords, "s#Oi",
 589                               name_scm, &name, rest,
 590                               &block_arg_pos, &block_scm,
 591                               &domain_arg_pos, &domain);
 592
 593   cleanups = make_cleanup (xfree, name);
 594
 595   if (block_arg_pos >= 0)
 596     {
 597       SCM except_scm;
 598
 599       block = bkscm_scm_to_block (block_scm, block_arg_pos, FUNC_NAME,
 600                                   &except_scm);
 601       if (block == NULL)
 602         {
 603           do_cleanups (cleanups);
 604           gdbscm_throw (except_scm);
 605         }
 606     }
 607   else
 608     {
 609       struct frame_info *selected_frame;
 610
 611       TRY
 612         {
 613           selected_frame = get_selected_frame (_("no frame selected"));
 614           block = get_frame_block (selected_frame, NULL);
 615         }
 616       CATCH (except, RETURN_MASK_ALL)
 617         {
 618           GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
 619         }
 620       END_CATCH
 621     }
 622
 623   TRY
 624     {
 625       symbol = lookup_symbol (name, block, domain, &is_a_field_of_this).symbol;
 626     }
 627   CATCH (ex, RETURN_MASK_ALL)
 628     {
 629       except = ex;
 630     }
 631   END_CATCH
 632
 633   do_cleanups (cleanups);
 634   GDBSCM_HANDLE_GDB_EXCEPTION (except);
 635
 636   if (symbol == NULL)
 637     return SCM_BOOL_F;
 638
 639   return scm_list_2 (syscm_scm_from_symbol (symbol),
 640                      scm_from_bool (is_a_field_of_this.type != NULL));
 641 }
 642
 643 /* (lookup-global-symbol name [#:domain domain]) -> <gdb:symbol>
 644    The result is #f if the symbol is not found.  */
 645
 646 static SCM
 647 gdbscm_lookup_global_symbol (SCM name_scm, SCM rest)
 648 {
 649   char *name;
 650   SCM keywords[] = { domain_keyword, SCM_BOOL_F };
 651   int domain_arg_pos = -1;
 652   int domain = VAR_DOMAIN;
 653   struct symbol *symbol = NULL;
 654   struct cleanup *cleanups;
 655   struct gdb_exception except = exception_none;
 656
 657   gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, keywords, "s#i",
 658                               name_scm, &name, rest,
 659                               &domain_arg_pos, &domain);
 660
 661   cleanups = make_cleanup (xfree, name);
 662
 663   TRY
 664     {
 665       symbol = lookup_global_symbol (name, NULL, domain).symbol;
 666     }
 667   CATCH (ex, RETURN_MASK_ALL)
 668     {
 669       except = ex;
 670     }
 671   END_CATCH
 672
 673   do_cleanups (cleanups);
 674   GDBSCM_HANDLE_GDB_EXCEPTION (except);
 675
 676   if (symbol == NULL)
 677     return SCM_BOOL_F;
 678
 679   return syscm_scm_from_symbol (symbol);
 680 }
 681 \f
 682 /* Initialize the Scheme symbol support.  */
 683
 684 /* Note: The SYMBOL_ prefix on the integer constants here is present for
 685    compatibility with the Python support.  */
 686
 687 static const scheme_integer_constant symbol_integer_constants[] =
 688 {
 689 #define X(SYM) { "SYMBOL_" #SYM, SYM }
 690   X (LOC_UNDEF),
 691   X (LOC_CONST),
 692   X (LOC_STATIC),
 693   X (LOC_REGISTER),
 694   X (LOC_ARG),
 695   X (LOC_REF_ARG),
 696   X (LOC_LOCAL),
 697   X (LOC_TYPEDEF),
 698   X (LOC_LABEL),
 699   X (LOC_BLOCK),
 700   X (LOC_CONST_BYTES),
 701   X (LOC_UNRESOLVED),
 702   X (LOC_OPTIMIZED_OUT),
 703   X (LOC_COMPUTED),
 704   X (LOC_REGPARM_ADDR),
 705
 706   X (UNDEF_DOMAIN),
 707   X (VAR_DOMAIN),
 708   X (STRUCT_DOMAIN),
 709   X (LABEL_DOMAIN),
 710   X (VARIABLES_DOMAIN),
 711   X (FUNCTIONS_DOMAIN),
 712   X (TYPES_DOMAIN),
 713 #undef X
 714
 715   END_INTEGER_CONSTANTS
 716 };
 717
 718 static const scheme_function symbol_functions[] =
 719 {
 720   { "symbol?", 1, 0, 0, as_a_scm_t_subr (gdbscm_symbol_p),
 721     "\
 722 Return #t if the object is a <gdb:symbol> object." },
 723
 724   { "symbol-valid?", 1, 0, 0, as_a_scm_t_subr (gdbscm_symbol_valid_p),
 725     "\
 726 Return #t if object is a valid <gdb:symbol> object.\n\
 727 A valid symbol is a symbol that has not been freed.\n\
 728 Symbols are freed when the objfile they come from is freed." },
 729
 730   { "symbol-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_symbol_type),
 731     "\
 732 Return the type of symbol." },
 733
 734   { "symbol-symtab", 1, 0, 0, as_a_scm_t_subr (gdbscm_symbol_symtab),
 735     "\
 736 Return the symbol table (<gdb:symtab>) containing symbol." },
 737
 738   { "symbol-line", 1, 0, 0, as_a_scm_t_subr (gdbscm_symbol_line),
 739     "\
 740 Return the line number at which the symbol was defined." },
 741
 742   { "symbol-name", 1, 0, 0, as_a_scm_t_subr (gdbscm_symbol_name),
 743     "\
 744 Return the name of the symbol as a string." },
 745
 746   { "symbol-linkage-name", 1, 0, 0,
 747     as_a_scm_t_subr (gdbscm_symbol_linkage_name),
 748     "\
 749 Return the linkage name of the symbol as a string." },
 750
 751   { "symbol-print-name", 1, 0, 0, as_a_scm_t_subr (gdbscm_symbol_print_name),
 752     "\
 753 Return the print name of the symbol as a string.\n\
 754 This is either name or linkage-name, depending on whether the user\n\
 755 asked GDB to display demangled or mangled names." },
 756
 757   { "symbol-addr-class", 1, 0, 0, as_a_scm_t_subr (gdbscm_symbol_addr_class),
 758     "\
 759 Return the address class of the symbol." },
 760
 761   { "symbol-needs-frame?", 1, 0, 0,
 762     as_a_scm_t_subr (gdbscm_symbol_needs_frame_p),
 763     "\
 764 Return #t if the symbol needs a frame to compute its value." },
 765
 766   { "symbol-argument?", 1, 0, 0, as_a_scm_t_subr (gdbscm_symbol_argument_p),
 767     "\
 768 Return #t if the symbol is a function argument." },
 769
 770   { "symbol-constant?", 1, 0, 0, as_a_scm_t_subr (gdbscm_symbol_constant_p),
 771     "\
 772 Return #t if the symbol is a constant." },
 773
 774   { "symbol-function?", 1, 0, 0, as_a_scm_t_subr (gdbscm_symbol_function_p),
 775     "\
 776 Return #t if the symbol is a function." },
 777
 778   { "symbol-variable?", 1, 0, 0, as_a_scm_t_subr (gdbscm_symbol_variable_p),
 779     "\
 780 Return #t if the symbol is a variable." },
 781
 782   { "symbol-value", 1, 0, 1, as_a_scm_t_subr (gdbscm_symbol_value),
 783     "\
 784 Return the value of the symbol.\n\
 785 \n\
 786   Arguments: <gdb:symbol> [#:frame frame]" },
 787
 788   { "lookup-symbol", 1, 0, 1, as_a_scm_t_subr (gdbscm_lookup_symbol),
 789     "\
 790 Return (<gdb:symbol> field-of-this?) if found, otherwise #f.\n\
 791 \n\
 792   Arguments: name [#:block block] [#:domain domain]\n\
 793     name:   a string containing the name of the symbol to lookup\n\
 794     block:  a <gdb:block> object\n\
 795     domain: a SYMBOL_*_DOMAIN value" },
 796
 797   { "lookup-global-symbol", 1, 0, 1,
 798     as_a_scm_t_subr (gdbscm_lookup_global_symbol),
 799     "\
 800 Return <gdb:symbol> if found, otherwise #f.\n\
 801 \n\
 802   Arguments: name [#:domain domain]\n\
 803     name:   a string containing the name of the symbol to lookup\n\
 804     domain: a SYMBOL_*_DOMAIN value" },
 805
 806   END_FUNCTIONS
 807 };
 808
 809 void
 810 gdbscm_initialize_symbols (void)
 811 {
 812   symbol_smob_tag
 813     = gdbscm_make_smob_type (symbol_smob_name, sizeof (symbol_smob));
 814   scm_set_smob_free (symbol_smob_tag, syscm_free_symbol_smob);
 815   scm_set_smob_print (symbol_smob_tag, syscm_print_symbol_smob);
 816
 817   gdbscm_define_integer_constants (symbol_integer_constants, 1);
 818   gdbscm_define_functions (symbol_functions, 1);
 819
 820   block_keyword = scm_from_latin1_keyword ("block");
 821   domain_keyword = scm_from_latin1_keyword ("domain");
 822   frame_keyword = scm_from_latin1_keyword ("frame");
 823
 824   /* Register an objfile "free" callback so we can properly
 825      invalidate symbols when an object file is about to be deleted.  */
 826   syscm_objfile_data_key
 827     = register_objfile_data_with_cleanup (NULL, syscm_del_objfile_symbols);
 828
 829   /* Arch-specific symbol data.  */
 830   syscm_gdbarch_data_key
 831     = gdbarch_data_register_post_init (syscm_init_arch_symbols);
 832 }