gdb/guile/scm-symbol.c

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