gdb/guile/scm-type.c

   1 /* Scheme interface to types.
   2
   3    Copyright (C) 2008-2019 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 "arch-utils.h"
  25 #include "value.h"
  26 #include "gdbtypes.h"
  27 #include "objfiles.h"
  28 #include "language.h"
  29 #include "common/vec.h"
  30 #include "bcache.h"
  31 #include "dwarf2loc.h"
  32 #include "typeprint.h"
  33 #include "guile-internal.h"
  34
  35 /* The <gdb:type> smob.
  36    The type is chained with all types associated with its objfile, if any.
  37    This lets us copy the underlying struct type when the objfile is
  38    deleted.
  39    The typedef for this struct is in guile-internal.h.  */
  40
  41 struct _type_smob
  42 {
  43   /* This always appears first.
  44      eqable_gdb_smob is used so that types are eq?-able.
  45      Also, a type object can be associated with an objfile.  eqable_gdb_smob
  46      lets us track the lifetime of all types associated with an objfile.
  47      When an objfile is deleted we need to invalidate the type object.  */
  48   eqable_gdb_smob base;
  49
  50   /* The GDB type structure this smob is wrapping.  */
  51   struct type *type;
  52 };
  53
  54 /* A field smob.  */
  55
  56 typedef struct
  57 {
  58   /* This always appears first.  */
  59   gdb_smob base;
  60
  61   /* Backlink to the containing <gdb:type> object.  */
  62   SCM type_scm;
  63
  64   /* The field number in TYPE_SCM.  */
  65   int field_num;
  66 } field_smob;
  67
  68 static const char type_smob_name[] = "gdb:type";
  69 static const char field_smob_name[] = "gdb:field";
  70
  71 static const char not_composite_error[] =
  72   N_("type is not a structure, union, or enum type");
  73
  74 /* The tag Guile knows the type smob by.  */
  75 static scm_t_bits type_smob_tag;
  76
  77 /* The tag Guile knows the field smob by.  */
  78 static scm_t_bits field_smob_tag;
  79
  80 /* The "next" procedure for field iterators.  */
  81 static SCM tyscm_next_field_x_proc;
  82
  83 /* Keywords used in argument passing.  */
  84 static SCM block_keyword;
  85
  86 static const struct objfile_data *tyscm_objfile_data_key;
  87
  88 /* Hash table to uniquify global (non-objfile-owned) types.  */
  89 static htab_t global_types_map;
  90
  91 static struct type *tyscm_get_composite (struct type *type);
  92
  93 /* Return the type field of T_SMOB.
  94    This exists so that we don't have to export the struct's contents.  */
  95
  96 struct type *
  97 tyscm_type_smob_type (type_smob *t_smob)
  98 {
  99   return t_smob->type;
 100 }
 101
 102 /* Return the name of TYPE in expanded form.  If there's an error
 103    computing the name, throws the gdb exception with scm_throw.  */
 104
 105 static std::string
 106 tyscm_type_name (struct type *type)
 107 {
 108   SCM excp;
 109   try
 110     {
 111       string_file stb;
 112
 113       LA_PRINT_TYPE (type, "", &stb, -1, 0, &type_print_raw_options);
 114       return std::move (stb.string ());
 115     }
 116   catch (const gdb_exception &except)
 117     {
 118       excp = gdbscm_scm_from_gdb_exception (unpack (except));
 119     }
 120
 121   gdbscm_throw (excp);
 122 }
 123 \f
 124 /* Administrivia for type smobs.  */
 125
 126 /* Helper function to hash a type_smob.  */
 127
 128 static hashval_t
 129 tyscm_hash_type_smob (const void *p)
 130 {
 131   const type_smob *t_smob = (const type_smob *) p;
 132
 133   return htab_hash_pointer (t_smob->type);
 134 }
 135
 136 /* Helper function to compute equality of type_smobs.  */
 137
 138 static int
 139 tyscm_eq_type_smob (const void *ap, const void *bp)
 140 {
 141   const type_smob *a = (const type_smob *) ap;
 142   const type_smob *b = (const type_smob *) bp;
 143
 144   return (a->type == b->type
 145           && a->type != NULL);
 146 }
 147
 148 /* Return the struct type pointer -> SCM mapping table.
 149    If type is owned by an objfile, the mapping table is created if necessary.
 150    Otherwise, type is not owned by an objfile, and we use
 151    global_types_map.  */
 152
 153 static htab_t
 154 tyscm_type_map (struct type *type)
 155 {
 156   struct objfile *objfile = TYPE_OBJFILE (type);
 157   htab_t htab;
 158
 159   if (objfile == NULL)
 160     return global_types_map;
 161
 162   htab = (htab_t) objfile_data (objfile, tyscm_objfile_data_key);
 163   if (htab == NULL)
 164     {
 165       htab = gdbscm_create_eqable_gsmob_ptr_map (tyscm_hash_type_smob,
 166                                                  tyscm_eq_type_smob);
 167       set_objfile_data (objfile, tyscm_objfile_data_key, htab);
 168     }
 169
 170   return htab;
 171 }
 172
 173 /* The smob "free" function for <gdb:type>.  */
 174
 175 static size_t
 176 tyscm_free_type_smob (SCM self)
 177 {
 178   type_smob *t_smob = (type_smob *) SCM_SMOB_DATA (self);
 179
 180   if (t_smob->type != NULL)
 181     {
 182       htab_t htab = tyscm_type_map (t_smob->type);
 183
 184       gdbscm_clear_eqable_gsmob_ptr_slot (htab, &t_smob->base);
 185     }
 186
 187   /* Not necessary, done to catch bugs.  */
 188   t_smob->type = NULL;
 189
 190   return 0;
 191 }
 192
 193 /* The smob "print" function for <gdb:type>.  */
 194
 195 static int
 196 tyscm_print_type_smob (SCM self, SCM port, scm_print_state *pstate)
 197 {
 198   type_smob *t_smob = (type_smob *) SCM_SMOB_DATA (self);
 199   std::string name = tyscm_type_name (t_smob->type);
 200
 201   /* pstate->writingp = zero if invoked by display/~A, and nonzero if
 202      invoked by write/~S.  What to do here may need to evolve.
 203      IWBN if we could pass an argument to format that would we could use
 204      instead of writingp.  */
 205   if (pstate->writingp)
 206     gdbscm_printf (port, "#<%s ", type_smob_name);
 207
 208   scm_puts (name.c_str (), port);
 209
 210   if (pstate->writingp)
 211     scm_puts (">", port);
 212
 213   scm_remember_upto_here_1 (self);
 214
 215   /* Non-zero means success.  */
 216   return 1;
 217 }
 218
 219 /* The smob "equal?" function for <gdb:type>.  */
 220
 221 static SCM
 222 tyscm_equal_p_type_smob (SCM type1_scm, SCM type2_scm)
 223 {
 224   type_smob *type1_smob, *type2_smob;
 225   struct type *type1, *type2;
 226   bool result = false;
 227
 228   SCM_ASSERT_TYPE (tyscm_is_type (type1_scm), type1_scm, SCM_ARG1, FUNC_NAME,
 229                    type_smob_name);
 230   SCM_ASSERT_TYPE (tyscm_is_type (type2_scm), type2_scm, SCM_ARG2, FUNC_NAME,
 231                    type_smob_name);
 232   type1_smob = (type_smob *) SCM_SMOB_DATA (type1_scm);
 233   type2_smob = (type_smob *) SCM_SMOB_DATA (type2_scm);
 234   type1 = type1_smob->type;
 235   type2 = type2_smob->type;
 236
 237   gdbscm_gdb_exception exc {};
 238   try
 239     {
 240       result = types_deeply_equal (type1, type2);
 241     }
 242   catch (const gdb_exception &except)
 243     {
 244       exc = unpack (except);
 245     }
 246
 247   GDBSCM_HANDLE_GDB_EXCEPTION (exc);
 248   return scm_from_bool (result);
 249 }
 250
 251 /* Low level routine to create a <gdb:type> object.  */
 252
 253 static SCM
 254 tyscm_make_type_smob (void)
 255 {
 256   type_smob *t_smob = (type_smob *)
 257     scm_gc_malloc (sizeof (type_smob), type_smob_name);
 258   SCM t_scm;
 259
 260   /* This must be filled in by the caller.  */
 261   t_smob->type = NULL;
 262
 263   t_scm = scm_new_smob (type_smob_tag, (scm_t_bits) t_smob);
 264   gdbscm_init_eqable_gsmob (&t_smob->base, t_scm);
 265
 266   return t_scm;
 267 }
 268
 269 /* Return non-zero if SCM is a <gdb:type> object.  */
 270
 271 int
 272 tyscm_is_type (SCM self)
 273 {
 274   return SCM_SMOB_PREDICATE (type_smob_tag, self);
 275 }
 276
 277 /* (type? object) -> boolean */
 278
 279 static SCM
 280 gdbscm_type_p (SCM self)
 281 {
 282   return scm_from_bool (tyscm_is_type (self));
 283 }
 284
 285 /* Return the existing object that encapsulates TYPE, or create a new
 286    <gdb:type> object.  */
 287
 288 SCM
 289 tyscm_scm_from_type (struct type *type)
 290 {
 291   htab_t htab;
 292   eqable_gdb_smob **slot;
 293   type_smob *t_smob, t_smob_for_lookup;
 294   SCM t_scm;
 295
 296   /* If we've already created a gsmob for this type, return it.
 297      This makes types eq?-able.  */
 298   htab = tyscm_type_map (type);
 299   t_smob_for_lookup.type = type;
 300   slot = gdbscm_find_eqable_gsmob_ptr_slot (htab, &t_smob_for_lookup.base);
 301   if (*slot != NULL)
 302     return (*slot)->containing_scm;
 303
 304   t_scm = tyscm_make_type_smob ();
 305   t_smob = (type_smob *) SCM_SMOB_DATA (t_scm);
 306   t_smob->type = type;
 307   gdbscm_fill_eqable_gsmob_ptr_slot (slot, &t_smob->base);
 308
 309   return t_scm;
 310 }
 311
 312 /* Returns the <gdb:type> object in SELF.
 313    Throws an exception if SELF is not a <gdb:type> object.  */
 314
 315 static SCM
 316 tyscm_get_type_arg_unsafe (SCM self, int arg_pos, const char *func_name)
 317 {
 318   SCM_ASSERT_TYPE (tyscm_is_type (self), self, arg_pos, func_name,
 319                    type_smob_name);
 320
 321   return self;
 322 }
 323
 324 /* Returns a pointer to the type smob of SELF.
 325    Throws an exception if SELF is not a <gdb:type> object.  */
 326
 327 type_smob *
 328 tyscm_get_type_smob_arg_unsafe (SCM self, int arg_pos, const char *func_name)
 329 {
 330   SCM t_scm = tyscm_get_type_arg_unsafe (self, arg_pos, func_name);
 331   type_smob *t_smob = (type_smob *) SCM_SMOB_DATA (t_scm);
 332
 333   return t_smob;
 334 }
 335
 336 /* Return the type field of T_SCM, an object of type <gdb:type>.
 337    This exists so that we don't have to export the struct's contents.  */
 338
 339 struct type *
 340 tyscm_scm_to_type (SCM t_scm)
 341 {
 342   type_smob *t_smob;
 343
 344   gdb_assert (tyscm_is_type (t_scm));
 345   t_smob = (type_smob *) SCM_SMOB_DATA (t_scm);
 346   return t_smob->type;
 347 }
 348
 349 /* Helper function for save_objfile_types to make a deep copy of the type.  */
 350
 351 static int
 352 tyscm_copy_type_recursive (void **slot, void *info)
 353 {
 354   type_smob *t_smob = (type_smob *) *slot;
 355   htab_t copied_types = (htab_t) info;
 356   struct objfile *objfile = TYPE_OBJFILE (t_smob->type);
 357   htab_t htab;
 358   eqable_gdb_smob **new_slot;
 359   type_smob t_smob_for_lookup;
 360
 361   gdb_assert (objfile != NULL);
 362
 363   htab_empty (copied_types);
 364   t_smob->type = copy_type_recursive (objfile, t_smob->type, copied_types);
 365
 366   /* The eq?-hashtab that the type lived in is going away.
 367      Add the type to its new eq?-hashtab: Otherwise if/when the type is later
 368      garbage collected we'll assert-fail if the type isn't in the hashtab.
 369      PR 16612.
 370
 371      Types now live in "arch space", and things like "char" that came from
 372      the objfile *could* be considered eq? with the arch "char" type.
 373      However, they weren't before the objfile got deleted, so making them
 374      eq? now is debatable.  */
 375   htab = tyscm_type_map (t_smob->type);
 376   t_smob_for_lookup.type = t_smob->type;
 377   new_slot = gdbscm_find_eqable_gsmob_ptr_slot (htab, &t_smob_for_lookup.base);
 378   gdb_assert (*new_slot == NULL);
 379   gdbscm_fill_eqable_gsmob_ptr_slot (new_slot, &t_smob->base);
 380
 381   return 1;
 382 }
 383
 384 /* Called when OBJFILE is about to be deleted.
 385    Make a copy of all types associated with OBJFILE.  */
 386
 387 static void
 388 save_objfile_types (struct objfile *objfile, void *datum)
 389 {
 390   htab_t htab = (htab_t) datum;
 391   htab_t copied_types;
 392
 393   if (!gdb_scheme_initialized)
 394     return;
 395
 396   copied_types = create_copied_types_hash (objfile);
 397
 398   if (htab != NULL)
 399     {
 400       htab_traverse_noresize (htab, tyscm_copy_type_recursive, copied_types);
 401       htab_delete (htab);
 402     }
 403
 404   htab_delete (copied_types);
 405 }
 406 \f
 407 /* Administrivia for field smobs.  */
 408
 409 /* The smob "print" function for <gdb:field>.  */
 410
 411 static int
 412 tyscm_print_field_smob (SCM self, SCM port, scm_print_state *pstate)
 413 {
 414   field_smob *f_smob = (field_smob *) SCM_SMOB_DATA (self);
 415
 416   gdbscm_printf (port, "#<%s ", field_smob_name);
 417   scm_write (f_smob->type_scm, port);
 418   gdbscm_printf (port, " %d", f_smob->field_num);
 419   scm_puts (">", port);
 420
 421   scm_remember_upto_here_1 (self);
 422
 423   /* Non-zero means success.  */
 424   return 1;
 425 }
 426
 427 /* Low level routine to create a <gdb:field> object for field FIELD_NUM
 428    of type TYPE_SCM.  */
 429
 430 static SCM
 431 tyscm_make_field_smob (SCM type_scm, int field_num)
 432 {
 433   field_smob *f_smob = (field_smob *)
 434     scm_gc_malloc (sizeof (field_smob), field_smob_name);
 435   SCM result;
 436
 437   f_smob->type_scm = type_scm;
 438   f_smob->field_num = field_num;
 439   result = scm_new_smob (field_smob_tag, (scm_t_bits) f_smob);
 440   gdbscm_init_gsmob (&f_smob->base);
 441
 442   return result;
 443 }
 444
 445 /* Return non-zero if SCM is a <gdb:field> object.  */
 446
 447 static int
 448 tyscm_is_field (SCM self)
 449 {
 450   return SCM_SMOB_PREDICATE (field_smob_tag, self);
 451 }
 452
 453 /* (field? object) -> boolean */
 454
 455 static SCM
 456 gdbscm_field_p (SCM self)
 457 {
 458   return scm_from_bool (tyscm_is_field (self));
 459 }
 460
 461 /* Create a new <gdb:field> object that encapsulates field FIELD_NUM
 462    in type TYPE_SCM.  */
 463
 464 SCM
 465 tyscm_scm_from_field (SCM type_scm, int field_num)
 466 {
 467   return tyscm_make_field_smob (type_scm, field_num);
 468 }
 469
 470 /* Returns the <gdb:field> object in SELF.
 471    Throws an exception if SELF is not a <gdb:field> object.  */
 472
 473 static SCM
 474 tyscm_get_field_arg_unsafe (SCM self, int arg_pos, const char *func_name)
 475 {
 476   SCM_ASSERT_TYPE (tyscm_is_field (self), self, arg_pos, func_name,
 477                    field_smob_name);
 478
 479   return self;
 480 }
 481
 482 /* Returns a pointer to the field smob of SELF.
 483    Throws an exception if SELF is not a <gdb:field> object.  */
 484
 485 static field_smob *
 486 tyscm_get_field_smob_arg_unsafe (SCM self, int arg_pos, const char *func_name)
 487 {
 488   SCM f_scm = tyscm_get_field_arg_unsafe (self, arg_pos, func_name);
 489   field_smob *f_smob = (field_smob *) SCM_SMOB_DATA (f_scm);
 490
 491   return f_smob;
 492 }
 493
 494 /* Returns a pointer to the type struct in F_SMOB
 495    (the type the field is in).  */
 496
 497 static struct type *
 498 tyscm_field_smob_containing_type (field_smob *f_smob)
 499 {
 500   type_smob *t_smob;
 501
 502   gdb_assert (tyscm_is_type (f_smob->type_scm));
 503   t_smob = (type_smob *) SCM_SMOB_DATA (f_smob->type_scm);
 504
 505   return t_smob->type;
 506 }
 507
 508 /* Returns a pointer to the field struct of F_SMOB.  */
 509
 510 static struct field *
 511 tyscm_field_smob_to_field (field_smob *f_smob)
 512 {
 513   struct type *type = tyscm_field_smob_containing_type (f_smob);
 514
 515   /* This should be non-NULL by construction.  */
 516   gdb_assert (TYPE_FIELDS (type) != NULL);
 517
 518   return &TYPE_FIELD (type, f_smob->field_num);
 519 }
 520 \f
 521 /* Type smob accessors.  */
 522
 523 /* (type-code <gdb:type>) -> integer
 524    Return the code for this type.  */
 525
 526 static SCM
 527 gdbscm_type_code (SCM self)
 528 {
 529   type_smob *t_smob
 530     = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 531   struct type *type = t_smob->type;
 532
 533   return scm_from_int (TYPE_CODE (type));
 534 }
 535
 536 /* (type-fields <gdb:type>) -> list
 537    Return a list of all fields.  Each element is a <gdb:field> object.
 538    This also supports arrays, we return a field list of one element,
 539    the range type.  */
 540
 541 static SCM
 542 gdbscm_type_fields (SCM self)
 543 {
 544   type_smob *t_smob
 545     = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 546   struct type *type = t_smob->type;
 547   struct type *containing_type;
 548   SCM containing_type_scm, result;
 549   int i;
 550
 551   containing_type = tyscm_get_composite (type);
 552   if (containing_type == NULL)
 553     gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, self,
 554                                _(not_composite_error));
 555
 556   /* If SELF is a typedef or reference, we want the underlying type,
 557      which is what tyscm_get_composite returns.  */
 558   if (containing_type == type)
 559     containing_type_scm = self;
 560   else
 561     containing_type_scm = tyscm_scm_from_type (containing_type);
 562
 563   result = SCM_EOL;
 564   for (i = 0; i < TYPE_NFIELDS (containing_type); ++i)
 565     result = scm_cons (tyscm_make_field_smob (containing_type_scm, i), result);
 566
 567   return scm_reverse_x (result, SCM_EOL);
 568 }
 569
 570 /* (type-tag <gdb:type>) -> string
 571    Return the type's tag, or #f.  */
 572
 573 static SCM
 574 gdbscm_type_tag (SCM self)
 575 {
 576   type_smob *t_smob
 577     = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 578   struct type *type = t_smob->type;
 579   const char *tagname = nullptr;
 580
 581   if (TYPE_CODE (type) == TYPE_CODE_STRUCT
 582       || TYPE_CODE (type) == TYPE_CODE_UNION
 583       || TYPE_CODE (type) == TYPE_CODE_ENUM)
 584     tagname = TYPE_NAME (type);
 585
 586   if (tagname == nullptr)
 587     return SCM_BOOL_F;
 588   return gdbscm_scm_from_c_string (tagname);
 589 }
 590
 591 /* (type-name <gdb:type>) -> string
 592    Return the type's name, or #f.  */
 593
 594 static SCM
 595 gdbscm_type_name (SCM self)
 596 {
 597   type_smob *t_smob
 598     = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 599   struct type *type = t_smob->type;
 600
 601   if (!TYPE_NAME (type))
 602     return SCM_BOOL_F;
 603   return gdbscm_scm_from_c_string (TYPE_NAME (type));
 604 }
 605
 606 /* (type-print-name <gdb:type>) -> string
 607    Return the print name of type.
 608    TODO: template support elided for now.  */
 609
 610 static SCM
 611 gdbscm_type_print_name (SCM self)
 612 {
 613   type_smob *t_smob
 614     = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 615   struct type *type = t_smob->type;
 616   std::string thetype = tyscm_type_name (type);
 617   SCM result = gdbscm_scm_from_c_string (thetype.c_str ());
 618
 619   return result;
 620 }
 621
 622 /* (type-sizeof <gdb:type>) -> integer
 623    Return the size of the type represented by SELF, in bytes.  */
 624
 625 static SCM
 626 gdbscm_type_sizeof (SCM self)
 627 {
 628   type_smob *t_smob
 629     = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 630   struct type *type = t_smob->type;
 631
 632   try
 633     {
 634       check_typedef (type);
 635     }
 636   catch (const gdb_exception &except)
 637     {
 638     }
 639
 640   /* Ignore exceptions.  */
 641
 642   return scm_from_long (TYPE_LENGTH (type));
 643 }
 644
 645 /* (type-strip-typedefs <gdb:type>) -> <gdb:type>
 646    Return the type, stripped of typedefs. */
 647
 648 static SCM
 649 gdbscm_type_strip_typedefs (SCM self)
 650 {
 651   type_smob *t_smob
 652     = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 653   struct type *type = t_smob->type;
 654
 655   gdbscm_gdb_exception exc {};
 656   try
 657     {
 658       type = check_typedef (type);
 659     }
 660   catch (const gdb_exception &except)
 661     {
 662       exc = unpack (except);
 663     }
 664
 665   GDBSCM_HANDLE_GDB_EXCEPTION (exc);
 666   return tyscm_scm_from_type (type);
 667 }
 668
 669 /* Strip typedefs and pointers/reference from a type.  Then check that
 670    it is a struct, union, or enum type.  If not, return NULL.  */
 671
 672 static struct type *
 673 tyscm_get_composite (struct type *type)
 674 {
 675
 676   for (;;)
 677     {
 678       gdbscm_gdb_exception exc {};
 679       try
 680         {
 681           type = check_typedef (type);
 682         }
 683       catch (const gdb_exception &except)
 684         {
 685           exc = unpack (except);
 686         }
 687
 688       GDBSCM_HANDLE_GDB_EXCEPTION (exc);
 689       if (TYPE_CODE (type) != TYPE_CODE_PTR
 690           && TYPE_CODE (type) != TYPE_CODE_REF)
 691         break;
 692       type = TYPE_TARGET_TYPE (type);
 693     }
 694
 695   /* If this is not a struct, union, or enum type, raise TypeError
 696      exception.  */
 697   if (TYPE_CODE (type) != TYPE_CODE_STRUCT
 698       && TYPE_CODE (type) != TYPE_CODE_UNION
 699       && TYPE_CODE (type) != TYPE_CODE_ENUM)
 700     return NULL;
 701
 702   return type;
 703 }
 704
 705 /* Helper for tyscm_array and tyscm_vector.  */
 706
 707 static SCM
 708 tyscm_array_1 (SCM self, SCM n1_scm, SCM n2_scm, int is_vector,
 709                const char *func_name)
 710 {
 711   type_smob *t_smob
 712     = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, func_name);
 713   struct type *type = t_smob->type;
 714   long n1, n2 = 0;
 715   struct type *array = NULL;
 716
 717   gdbscm_parse_function_args (func_name, SCM_ARG2, NULL, "l|l",
 718                               n1_scm, &n1, n2_scm, &n2);
 719
 720   if (SCM_UNBNDP (n2_scm))
 721     {
 722       n2 = n1;
 723       n1 = 0;
 724     }
 725
 726   if (n2 < n1 - 1) /* Note: An empty array has n2 == n1 - 1.  */
 727     {
 728       gdbscm_out_of_range_error (func_name, SCM_ARG3,
 729                                  scm_cons (scm_from_long (n1),
 730                                            scm_from_long (n2)),
 731                                  _("Array length must not be negative"));
 732     }
 733
 734   gdbscm_gdb_exception exc {};
 735   try
 736     {
 737       array = lookup_array_range_type (type, n1, n2);
 738       if (is_vector)
 739         make_vector_type (array);
 740     }
 741   catch (const gdb_exception &except)
 742     {
 743       exc = unpack (except);
 744     }
 745
 746   GDBSCM_HANDLE_GDB_EXCEPTION (exc);
 747   return tyscm_scm_from_type (array);
 748 }
 749
 750 /* (type-array <gdb:type> [low-bound] high-bound) -> <gdb:type>
 751    The array has indices [low-bound,high-bound].
 752    If low-bound is not provided zero is used.
 753    Return an array type.
 754
 755    IWBN if the one argument version specified a size, not the high bound.
 756    It's too easy to pass one argument thinking it is the size of the array.
 757    The current semantics are for compatibility with the Python version.
 758    Later we can add #:size.  */
 759
 760 static SCM
 761 gdbscm_type_array (SCM self, SCM n1, SCM n2)
 762 {
 763   return tyscm_array_1 (self, n1, n2, 0, FUNC_NAME);
 764 }
 765
 766 /* (type-vector <gdb:type> [low-bound] high-bound) -> <gdb:type>
 767    The array has indices [low-bound,high-bound].
 768    If low-bound is not provided zero is used.
 769    Return a vector type.
 770
 771    IWBN if the one argument version specified a size, not the high bound.
 772    It's too easy to pass one argument thinking it is the size of the array.
 773    The current semantics are for compatibility with the Python version.
 774    Later we can add #:size.  */
 775
 776 static SCM
 777 gdbscm_type_vector (SCM self, SCM n1, SCM n2)
 778 {
 779   return tyscm_array_1 (self, n1, n2, 1, FUNC_NAME);
 780 }
 781
 782 /* (type-pointer <gdb:type>) -> <gdb:type>
 783    Return a <gdb:type> object which represents a pointer to SELF.  */
 784
 785 static SCM
 786 gdbscm_type_pointer (SCM self)
 787 {
 788   type_smob *t_smob
 789     = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 790   struct type *type = t_smob->type;
 791
 792   gdbscm_gdb_exception exc {};
 793   try
 794     {
 795       type = lookup_pointer_type (type);
 796     }
 797   catch (const gdb_exception &except)
 798     {
 799       exc = unpack (except);
 800     }
 801
 802   GDBSCM_HANDLE_GDB_EXCEPTION (exc);
 803   return tyscm_scm_from_type (type);
 804 }
 805
 806 /* (type-range <gdb:type>) -> (low high)
 807    Return the range of a type represented by SELF.  The return type is
 808    a list.  The first element is the low bound, and the second element
 809    is the high bound.  */
 810
 811 static SCM
 812 gdbscm_type_range (SCM self)
 813 {
 814   type_smob *t_smob
 815     = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 816   struct type *type = t_smob->type;
 817   SCM low_scm, high_scm;
 818   /* Initialize these to appease GCC warnings.  */
 819   LONGEST low = 0, high = 0;
 820
 821   SCM_ASSERT_TYPE (TYPE_CODE (type) == TYPE_CODE_ARRAY
 822                    || TYPE_CODE (type) == TYPE_CODE_STRING
 823                    || TYPE_CODE (type) == TYPE_CODE_RANGE,
 824                    self, SCM_ARG1, FUNC_NAME, _("ranged type"));
 825
 826   switch (TYPE_CODE (type))
 827     {
 828     case TYPE_CODE_ARRAY:
 829     case TYPE_CODE_STRING:
 830       low = TYPE_LOW_BOUND (TYPE_INDEX_TYPE (type));
 831       high = TYPE_HIGH_BOUND (TYPE_INDEX_TYPE (type));
 832       break;
 833     case TYPE_CODE_RANGE:
 834       low = TYPE_LOW_BOUND (type);
 835       high = TYPE_HIGH_BOUND (type);
 836       break;
 837     }
 838
 839   low_scm = gdbscm_scm_from_longest (low);
 840   high_scm = gdbscm_scm_from_longest (high);
 841
 842   return scm_list_2 (low_scm, high_scm);
 843 }
 844
 845 /* (type-reference <gdb:type>) -> <gdb:type>
 846    Return a <gdb:type> object which represents a reference to SELF.  */
 847
 848 static SCM
 849 gdbscm_type_reference (SCM self)
 850 {
 851   type_smob *t_smob
 852     = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 853   struct type *type = t_smob->type;
 854
 855   gdbscm_gdb_exception exc {};
 856   try
 857     {
 858       type = lookup_lvalue_reference_type (type);
 859     }
 860   catch (const gdb_exception &except)
 861     {
 862       exc = unpack (except);
 863     }
 864
 865   GDBSCM_HANDLE_GDB_EXCEPTION (exc);
 866   return tyscm_scm_from_type (type);
 867 }
 868
 869 /* (type-target <gdb:type>) -> <gdb:type>
 870    Return a <gdb:type> object which represents the target type of SELF.  */
 871
 872 static SCM
 873 gdbscm_type_target (SCM self)
 874 {
 875   type_smob *t_smob
 876     = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 877   struct type *type = t_smob->type;
 878
 879   SCM_ASSERT (TYPE_TARGET_TYPE (type), self, SCM_ARG1, FUNC_NAME);
 880
 881   return tyscm_scm_from_type (TYPE_TARGET_TYPE (type));
 882 }
 883
 884 /* (type-const <gdb:type>) -> <gdb:type>
 885    Return a const-qualified type variant.  */
 886
 887 static SCM
 888 gdbscm_type_const (SCM self)
 889 {
 890   type_smob *t_smob
 891     = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 892   struct type *type = t_smob->type;
 893
 894   gdbscm_gdb_exception exc {};
 895   try
 896     {
 897       type = make_cv_type (1, 0, type, NULL);
 898     }
 899   catch (const gdb_exception &except)
 900     {
 901       exc = unpack (except);
 902     }
 903
 904   GDBSCM_HANDLE_GDB_EXCEPTION (exc);
 905   return tyscm_scm_from_type (type);
 906 }
 907
 908 /* (type-volatile <gdb:type>) -> <gdb:type>
 909    Return a volatile-qualified type variant.  */
 910
 911 static SCM
 912 gdbscm_type_volatile (SCM self)
 913 {
 914   type_smob *t_smob
 915     = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 916   struct type *type = t_smob->type;
 917
 918   gdbscm_gdb_exception exc {};
 919   try
 920     {
 921       type = make_cv_type (0, 1, type, NULL);
 922     }
 923   catch (const gdb_exception &except)
 924     {
 925       exc = unpack (except);
 926     }
 927
 928   GDBSCM_HANDLE_GDB_EXCEPTION (exc);
 929   return tyscm_scm_from_type (type);
 930 }
 931
 932 /* (type-unqualified <gdb:type>) -> <gdb:type>
 933    Return an unqualified type variant.  */
 934
 935 static SCM
 936 gdbscm_type_unqualified (SCM self)
 937 {
 938   type_smob *t_smob
 939     = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 940   struct type *type = t_smob->type;
 941
 942   gdbscm_gdb_exception exc {};
 943   try
 944     {
 945       type = make_cv_type (0, 0, type, NULL);
 946     }
 947   catch (const gdb_exception &except)
 948     {
 949       exc = unpack (except);
 950     }
 951
 952   GDBSCM_HANDLE_GDB_EXCEPTION (exc);
 953   return tyscm_scm_from_type (type);
 954 }
 955 \f
 956 /* Field related accessors of types.  */
 957
 958 /* (type-num-fields <gdb:type>) -> integer
 959    Return number of fields.  */
 960
 961 static SCM
 962 gdbscm_type_num_fields (SCM self)
 963 {
 964   type_smob *t_smob
 965     = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 966   struct type *type = t_smob->type;
 967
 968   type = tyscm_get_composite (type);
 969   if (type == NULL)
 970     gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, self,
 971                                _(not_composite_error));
 972
 973   return scm_from_long (TYPE_NFIELDS (type));
 974 }
 975
 976 /* (type-field <gdb:type> string) -> <gdb:field>
 977    Return the <gdb:field> object for the field named by the argument.  */
 978
 979 static SCM
 980 gdbscm_type_field (SCM self, SCM field_scm)
 981 {
 982   type_smob *t_smob
 983     = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 984   struct type *type = t_smob->type;
 985
 986   SCM_ASSERT_TYPE (scm_is_string (field_scm), field_scm, SCM_ARG2, FUNC_NAME,
 987                    _("string"));
 988
 989   /* We want just fields of this type, not of base types, so instead of
 990      using lookup_struct_elt_type, portions of that function are
 991      copied here.  */
 992
 993   type = tyscm_get_composite (type);
 994   if (type == NULL)
 995     gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, self,
 996                                _(not_composite_error));
 997
 998   {
 999     gdb::unique_xmalloc_ptr<char> field = gdbscm_scm_to_c_string (field_scm);
1000
1001     for (int i = 0; i < TYPE_NFIELDS (type); i++)
1002       {
1003         const char *t_field_name = TYPE_FIELD_NAME (type, i);
1004
1005         if (t_field_name && (strcmp_iw (t_field_name, field.get ()) == 0))
1006           {
1007             field.reset (nullptr);
1008             return tyscm_make_field_smob (self, i);
1009           }
1010       }
1011   }
1012
1013   gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, field_scm,
1014                              _("Unknown field"));
1015 }
1016
1017 /* (type-has-field? <gdb:type> string) -> boolean
1018    Return boolean indicating if type SELF has FIELD_SCM (a string).  */
1019
1020 static SCM
1021 gdbscm_type_has_field_p (SCM self, SCM field_scm)
1022 {
1023   type_smob *t_smob
1024     = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1025   struct type *type = t_smob->type;
1026
1027   SCM_ASSERT_TYPE (scm_is_string (field_scm), field_scm, SCM_ARG2, FUNC_NAME,
1028                    _("string"));
1029
1030   /* We want just fields of this type, not of base types, so instead of
1031      using lookup_struct_elt_type, portions of that function are
1032      copied here.  */
1033
1034   type = tyscm_get_composite (type);
1035   if (type == NULL)
1036     gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, self,
1037                                _(not_composite_error));
1038
1039   {
1040     gdb::unique_xmalloc_ptr<char> field
1041       = gdbscm_scm_to_c_string (field_scm);
1042
1043     for (int i = 0; i < TYPE_NFIELDS (type); i++)
1044       {
1045         const char *t_field_name = TYPE_FIELD_NAME (type, i);
1046
1047         if (t_field_name && (strcmp_iw (t_field_name, field.get ()) == 0))
1048           return SCM_BOOL_T;
1049       }
1050   }
1051
1052   return SCM_BOOL_F;
1053 }
1054
1055 /* (make-field-iterator <gdb:type>) -> <gdb:iterator>
1056    Make a field iterator object.  */
1057
1058 static SCM
1059 gdbscm_make_field_iterator (SCM self)
1060 {
1061   type_smob *t_smob
1062     = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1063   struct type *type = t_smob->type;
1064   struct type *containing_type;
1065   SCM containing_type_scm;
1066
1067   containing_type = tyscm_get_composite (type);
1068   if (containing_type == NULL)
1069     gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, self,
1070                                _(not_composite_error));
1071
1072   /* If SELF is a typedef or reference, we want the underlying type,
1073      which is what tyscm_get_composite returns.  */
1074   if (containing_type == type)
1075     containing_type_scm = self;
1076   else
1077     containing_type_scm = tyscm_scm_from_type (containing_type);
1078
1079   return gdbscm_make_iterator (containing_type_scm, scm_from_int (0),
1080                                tyscm_next_field_x_proc);
1081 }
1082
1083 /* (type-next-field! <gdb:iterator>) -> <gdb:field>
1084    Return the next field in the iteration through the list of fields of the
1085    type, or (end-of-iteration).
1086    SELF is a <gdb:iterator> object created by gdbscm_make_field_iterator.
1087    This is the next! <gdb:iterator> function, not exported to the user.  */
1088
1089 static SCM
1090 gdbscm_type_next_field_x (SCM self)
1091 {
1092   iterator_smob *i_smob;
1093   type_smob *t_smob;
1094   struct type *type;
1095   SCM it_scm, result, progress, object;
1096   int field;
1097
1098   it_scm = itscm_get_iterator_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1099   i_smob = (iterator_smob *) SCM_SMOB_DATA (it_scm);
1100   object = itscm_iterator_smob_object (i_smob);
1101   progress = itscm_iterator_smob_progress (i_smob);
1102
1103   SCM_ASSERT_TYPE (tyscm_is_type (object), object,
1104                    SCM_ARG1, FUNC_NAME, type_smob_name);
1105   t_smob = (type_smob *) SCM_SMOB_DATA (object);
1106   type = t_smob->type;
1107
1108   SCM_ASSERT_TYPE (scm_is_signed_integer (progress,
1109                                           0, TYPE_NFIELDS (type)),
1110                    progress, SCM_ARG1, FUNC_NAME, _("integer"));
1111   field = scm_to_int (progress);
1112
1113   if (field < TYPE_NFIELDS (type))
1114     {
1115       result = tyscm_make_field_smob (object, field);
1116       itscm_set_iterator_smob_progress_x (i_smob, scm_from_int (field + 1));
1117       return result;
1118     }
1119
1120   return gdbscm_end_of_iteration ();
1121 }
1122 \f
1123 /* Field smob accessors.  */
1124
1125 /* (field-name <gdb:field>) -> string
1126    Return the name of this field or #f if there isn't one.  */
1127
1128 static SCM
1129 gdbscm_field_name (SCM self)
1130 {
1131   field_smob *f_smob
1132     = tyscm_get_field_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1133   struct field *field = tyscm_field_smob_to_field (f_smob);
1134
1135   if (FIELD_NAME (*field))
1136     return gdbscm_scm_from_c_string (FIELD_NAME (*field));
1137   return SCM_BOOL_F;
1138 }
1139
1140 /* (field-type <gdb:field>) -> <gdb:type>
1141    Return the <gdb:type> object of the field or #f if there isn't one.  */
1142
1143 static SCM
1144 gdbscm_field_type (SCM self)
1145 {
1146   field_smob *f_smob
1147     = tyscm_get_field_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1148   struct field *field = tyscm_field_smob_to_field (f_smob);
1149
1150   /* A field can have a NULL type in some situations.  */
1151   if (FIELD_TYPE (*field))
1152     return tyscm_scm_from_type (FIELD_TYPE (*field));
1153   return SCM_BOOL_F;
1154 }
1155
1156 /* (field-enumval <gdb:field>) -> integer
1157    For enum values, return its value as an integer.  */
1158
1159 static SCM
1160 gdbscm_field_enumval (SCM self)
1161 {
1162   field_smob *f_smob
1163     = tyscm_get_field_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1164   struct field *field = tyscm_field_smob_to_field (f_smob);
1165   struct type *type = tyscm_field_smob_containing_type (f_smob);
1166
1167   SCM_ASSERT_TYPE (TYPE_CODE (type) == TYPE_CODE_ENUM,
1168                    self, SCM_ARG1, FUNC_NAME, _("enum type"));
1169
1170   return scm_from_long (FIELD_ENUMVAL (*field));
1171 }
1172
1173 /* (field-bitpos <gdb:field>) -> integer
1174    For bitfields, return its offset in bits.  */
1175
1176 static SCM
1177 gdbscm_field_bitpos (SCM self)
1178 {
1179   field_smob *f_smob
1180     = tyscm_get_field_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1181   struct field *field = tyscm_field_smob_to_field (f_smob);
1182   struct type *type = tyscm_field_smob_containing_type (f_smob);
1183
1184   SCM_ASSERT_TYPE (TYPE_CODE (type) != TYPE_CODE_ENUM,
1185                    self, SCM_ARG1, FUNC_NAME, _("non-enum type"));
1186
1187   return scm_from_long (FIELD_BITPOS (*field));
1188 }
1189
1190 /* (field-bitsize <gdb:field>) -> integer
1191    Return the size of the field in bits.  */
1192
1193 static SCM
1194 gdbscm_field_bitsize (SCM self)
1195 {
1196   field_smob *f_smob
1197     = tyscm_get_field_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1198   struct field *field = tyscm_field_smob_to_field (f_smob);
1199
1200   return scm_from_long (FIELD_BITPOS (*field));
1201 }
1202
1203 /* (field-artificial? <gdb:field>) -> boolean
1204    Return #t if field is artificial.  */
1205
1206 static SCM
1207 gdbscm_field_artificial_p (SCM self)
1208 {
1209   field_smob *f_smob
1210     = tyscm_get_field_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1211   struct field *field = tyscm_field_smob_to_field (f_smob);
1212
1213   return scm_from_bool (FIELD_ARTIFICIAL (*field));
1214 }
1215
1216 /* (field-baseclass? <gdb:field>) -> boolean
1217    Return #t if field is a baseclass.  */
1218
1219 static SCM
1220 gdbscm_field_baseclass_p (SCM self)
1221 {
1222   field_smob *f_smob
1223     = tyscm_get_field_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1224   struct type *type = tyscm_field_smob_containing_type (f_smob);
1225
1226   if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1227     return scm_from_bool (f_smob->field_num < TYPE_N_BASECLASSES (type));
1228   return SCM_BOOL_F;
1229 }
1230 \f
1231 /* Return the type named TYPE_NAME in BLOCK.
1232    Returns NULL if not found.
1233    This routine does not throw an error.  */
1234
1235 static struct type *
1236 tyscm_lookup_typename (const char *type_name, const struct block *block)
1237 {
1238   struct type *type = NULL;
1239
1240   try
1241     {
1242       if (startswith (type_name, "struct "))
1243         type = lookup_struct (type_name + 7, NULL);
1244       else if (startswith (type_name, "union "))
1245         type = lookup_union (type_name + 6, NULL);
1246       else if (startswith (type_name, "enum "))
1247         type = lookup_enum (type_name + 5, NULL);
1248       else
1249         type = lookup_typename (current_language, get_current_arch (),
1250                                 type_name, block, 0);
1251     }
1252   catch (const gdb_exception &except)
1253     {
1254       return NULL;
1255     }
1256
1257   return type;
1258 }
1259
1260 /* (lookup-type name [#:block <gdb:block>]) -> <gdb:type>
1261    TODO: legacy template support left out until needed.  */
1262
1263 static SCM
1264 gdbscm_lookup_type (SCM name_scm, SCM rest)
1265 {
1266   SCM keywords[] = { block_keyword, SCM_BOOL_F };
1267   char *name;
1268   SCM block_scm = SCM_BOOL_F;
1269   int block_arg_pos = -1;
1270   const struct block *block = NULL;
1271   struct type *type;
1272
1273   gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, keywords, "s#O",
1274                               name_scm, &name,
1275                               rest, &block_arg_pos, &block_scm);
1276
1277   if (block_arg_pos != -1)
1278     {
1279       SCM exception;
1280
1281       block = bkscm_scm_to_block (block_scm, block_arg_pos, FUNC_NAME,
1282                                   &exception);
1283       if (block == NULL)
1284         {
1285           xfree (name);
1286           gdbscm_throw (exception);
1287         }
1288     }
1289   type = tyscm_lookup_typename (name, block);
1290   xfree (name);
1291
1292   if (type != NULL)
1293     return tyscm_scm_from_type (type);
1294   return SCM_BOOL_F;
1295 }
1296 \f
1297 /* Initialize the Scheme type code.  */
1298
1299
1300 static const scheme_integer_constant type_integer_constants[] =
1301 {
1302 #define X(SYM) { #SYM, SYM }
1303   X (TYPE_CODE_BITSTRING),
1304   X (TYPE_CODE_PTR),
1305   X (TYPE_CODE_ARRAY),
1306   X (TYPE_CODE_STRUCT),
1307   X (TYPE_CODE_UNION),
1308   X (TYPE_CODE_ENUM),
1309   X (TYPE_CODE_FLAGS),
1310   X (TYPE_CODE_FUNC),
1311   X (TYPE_CODE_INT),
1312   X (TYPE_CODE_FLT),
1313   X (TYPE_CODE_VOID),
1314   X (TYPE_CODE_SET),
1315   X (TYPE_CODE_RANGE),
1316   X (TYPE_CODE_STRING),
1317   X (TYPE_CODE_ERROR),
1318   X (TYPE_CODE_METHOD),
1319   X (TYPE_CODE_METHODPTR),
1320   X (TYPE_CODE_MEMBERPTR),
1321   X (TYPE_CODE_REF),
1322   X (TYPE_CODE_CHAR),
1323   X (TYPE_CODE_BOOL),
1324   X (TYPE_CODE_COMPLEX),
1325   X (TYPE_CODE_TYPEDEF),
1326   X (TYPE_CODE_NAMESPACE),
1327   X (TYPE_CODE_DECFLOAT),
1328   X (TYPE_CODE_INTERNAL_FUNCTION),
1329 #undef X
1330
1331   END_INTEGER_CONSTANTS
1332 };
1333
1334 static const scheme_function type_functions[] =
1335 {
1336   { "type?", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_p),
1337     "\
1338 Return #t if the object is a <gdb:type> object." },
1339
1340   { "lookup-type", 1, 0, 1, as_a_scm_t_subr (gdbscm_lookup_type),
1341     "\
1342 Return the <gdb:type> object representing string or #f if not found.\n\
1343 If block is given then the type is looked for in that block.\n\
1344 \n\
1345   Arguments: string [#:block <gdb:block>]" },
1346
1347   { "type-code", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_code),
1348     "\
1349 Return the code of the type" },
1350
1351   { "type-tag", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_tag),
1352     "\
1353 Return the tag name of the type, or #f if there isn't one." },
1354
1355   { "type-name", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_name),
1356     "\
1357 Return the name of the type as a string, or #f if there isn't one." },
1358
1359   { "type-print-name", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_print_name),
1360     "\
1361 Return the print name of the type as a string." },
1362
1363   { "type-sizeof", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_sizeof),
1364     "\
1365 Return the size of the type, in bytes." },
1366
1367   { "type-strip-typedefs", 1, 0, 0,
1368     as_a_scm_t_subr (gdbscm_type_strip_typedefs),
1369     "\
1370 Return a type formed by stripping the type of all typedefs." },
1371
1372   { "type-array", 2, 1, 0, as_a_scm_t_subr (gdbscm_type_array),
1373     "\
1374 Return a type representing an array of objects of the type.\n\
1375 \n\
1376   Arguments: <gdb:type> [low-bound] high-bound\n\
1377     If low-bound is not provided zero is used.\n\
1378     N.B. If only the high-bound parameter is specified, it is not\n\
1379     the array size.\n\
1380     Valid bounds for array indices are [low-bound,high-bound]." },
1381
1382   { "type-vector", 2, 1, 0, as_a_scm_t_subr (gdbscm_type_vector),
1383     "\
1384 Return a type representing a vector of objects of the type.\n\
1385 Vectors differ from arrays in that if the current language has C-style\n\
1386 arrays, vectors don't decay to a pointer to the first element.\n\
1387 They are first class values.\n\
1388 \n\
1389   Arguments: <gdb:type> [low-bound] high-bound\n\
1390     If low-bound is not provided zero is used.\n\
1391     N.B. If only the high-bound parameter is specified, it is not\n\
1392     the array size.\n\
1393     Valid bounds for array indices are [low-bound,high-bound]." },
1394
1395   { "type-pointer", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_pointer),
1396     "\
1397 Return a type of pointer to the type." },
1398
1399   { "type-range", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_range),
1400     "\
1401 Return (low high) representing the range for the type." },
1402
1403   { "type-reference", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_reference),
1404     "\
1405 Return a type of reference to the type." },
1406
1407   { "type-target", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_target),
1408     "\
1409 Return the target type of the type." },
1410
1411   { "type-const", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_const),
1412     "\
1413 Return a const variant of the type." },
1414
1415   { "type-volatile", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_volatile),
1416     "\
1417 Return a volatile variant of the type." },
1418
1419   { "type-unqualified", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_unqualified),
1420     "\
1421 Return a variant of the type without const or volatile attributes." },
1422
1423   { "type-num-fields", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_num_fields),
1424     "\
1425 Return the number of fields of the type." },
1426
1427   { "type-fields", 1, 0, 0, as_a_scm_t_subr (gdbscm_type_fields),
1428     "\
1429 Return the list of <gdb:field> objects of fields of the type." },
1430
1431   { "make-field-iterator", 1, 0, 0,
1432     as_a_scm_t_subr (gdbscm_make_field_iterator),
1433     "\
1434 Return a <gdb:iterator> object for iterating over the fields of the type." },
1435
1436   { "type-field", 2, 0, 0, as_a_scm_t_subr (gdbscm_type_field),
1437     "\
1438 Return the field named by string of the type.\n\
1439 \n\
1440   Arguments: <gdb:type> string" },
1441
1442   { "type-has-field?", 2, 0, 0, as_a_scm_t_subr (gdbscm_type_has_field_p),
1443     "\
1444 Return #t if the type has field named string.\n\
1445 \n\
1446   Arguments: <gdb:type> string" },
1447
1448   { "field?", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_p),
1449     "\
1450 Return #t if the object is a <gdb:field> object." },
1451
1452   { "field-name", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_name),
1453     "\
1454 Return the name of the field." },
1455
1456   { "field-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_type),
1457     "\
1458 Return the type of the field." },
1459
1460   { "field-enumval", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_enumval),
1461     "\
1462 Return the enum value represented by the field." },
1463
1464   { "field-bitpos", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_bitpos),
1465     "\
1466 Return the offset in bits of the field in its containing type." },
1467
1468   { "field-bitsize", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_bitsize),
1469     "\
1470 Return the size of the field in bits." },
1471
1472   { "field-artificial?", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_artificial_p),
1473     "\
1474 Return #t if the field is artificial." },
1475
1476   { "field-baseclass?", 1, 0, 0, as_a_scm_t_subr (gdbscm_field_baseclass_p),
1477     "\
1478 Return #t if the field is a baseclass." },
1479
1480   END_FUNCTIONS
1481 };
1482
1483 void
1484 gdbscm_initialize_types (void)
1485 {
1486   type_smob_tag = gdbscm_make_smob_type (type_smob_name, sizeof (type_smob));
1487   scm_set_smob_free (type_smob_tag, tyscm_free_type_smob);
1488   scm_set_smob_print (type_smob_tag, tyscm_print_type_smob);
1489   scm_set_smob_equalp (type_smob_tag, tyscm_equal_p_type_smob);
1490
1491   field_smob_tag = gdbscm_make_smob_type (field_smob_name,
1492                                           sizeof (field_smob));
1493   scm_set_smob_print (field_smob_tag, tyscm_print_field_smob);
1494
1495   gdbscm_define_integer_constants (type_integer_constants, 1);
1496   gdbscm_define_functions (type_functions, 1);
1497
1498   /* This function is "private".  */
1499   tyscm_next_field_x_proc
1500     = scm_c_define_gsubr ("%type-next-field!", 1, 0, 0,
1501                           as_a_scm_t_subr (gdbscm_type_next_field_x));
1502   scm_set_procedure_property_x (tyscm_next_field_x_proc,
1503                                 gdbscm_documentation_symbol,
1504                                 gdbscm_scm_from_c_string ("\
1505 Internal function to assist the type fields iterator."));
1506
1507   block_keyword = scm_from_latin1_keyword ("block");
1508
1509   /* Register an objfile "free" callback so we can properly copy types
1510      associated with the objfile when it's about to be deleted.  */
1511   tyscm_objfile_data_key
1512     = register_objfile_data_with_cleanup (save_objfile_types, NULL);
1513
1514   global_types_map = gdbscm_create_eqable_gsmob_ptr_map (tyscm_hash_type_smob,
1515                                                          tyscm_eq_type_smob);
1516 }