gdb/guile/scm-arch.c

   1 /* Scheme interface to architecture.
   2
   3    Copyright (C) 2014 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 "charset.h"
  25 #include "gdbarch.h"
  26 #include "arch-utils.h"
  27 #include "guile-internal.h"
  28
  29 /* The <gdb:arch> smob.
  30    The typedef for this struct is in guile-internal.h.  */
  31
  32 struct _arch_smob
  33 {
  34   /* This always appears first.  */
  35   gdb_smob base;
  36
  37   struct gdbarch *gdbarch;
  38 };
  39
  40 static const char arch_smob_name[] = "gdb:arch";
  41
  42 /* The tag Guile knows the arch smob by.  */
  43 static scm_t_bits arch_smob_tag;
  44
  45 static struct gdbarch_data *arch_object_data = NULL;
  46
  47 static int arscm_is_arch (SCM);
  48 \f
  49 /* Administrivia for arch smobs.  */
  50
  51 /* The smob "mark" function for <gdb:arch>.  */
  52
  53 static SCM
  54 arscm_mark_arch_smob (SCM self)
  55 {
  56   arch_smob *a_smob = (arch_smob *) SCM_SMOB_DATA (self);
  57
  58   /* Do this last.  */
  59   return gdbscm_mark_gsmob (&a_smob->base);
  60 }
  61
  62 /* The smob "print" function for <gdb:arch>.  */
  63
  64 static int
  65 arscm_print_arch_smob (SCM self, SCM port, scm_print_state *pstate)
  66 {
  67   arch_smob *a_smob = (arch_smob *) SCM_SMOB_DATA (self);
  68   struct gdbarch *gdbarch = a_smob->gdbarch;
  69
  70   gdbscm_printf (port, "#<%s", arch_smob_name);
  71   gdbscm_printf (port, " %s", gdbarch_bfd_arch_info (gdbarch)->printable_name);
  72   scm_puts (">", port);
  73
  74   scm_remember_upto_here_1 (self);
  75
  76   /* Non-zero means success.  */
  77   return 1;
  78 }
  79
  80 /* Low level routine to create a <gdb:arch> object for GDBARCH.  */
  81
  82 static SCM
  83 arscm_make_arch_smob (struct gdbarch *gdbarch)
  84 {
  85   arch_smob *a_smob = (arch_smob *)
  86     scm_gc_malloc (sizeof (arch_smob), arch_smob_name);
  87   SCM a_scm;
  88
  89   a_smob->gdbarch = gdbarch;
  90   a_scm = scm_new_smob (arch_smob_tag, (scm_t_bits) a_smob);
  91   gdbscm_init_gsmob (&a_smob->base);
  92
  93   return a_scm;
  94 }
  95
  96 /* Return the gdbarch field of A_SMOB.  */
  97
  98 struct gdbarch *
  99 arscm_get_gdbarch (arch_smob *a_smob)
 100 {
 101   return a_smob->gdbarch;
 102 }
 103
 104 /* Return non-zero if SCM is an architecture smob.  */
 105
 106 static int
 107 arscm_is_arch (SCM scm)
 108 {
 109   return SCM_SMOB_PREDICATE (arch_smob_tag, scm);
 110 }
 111
 112 /* (arch? object) -> boolean */
 113
 114 static SCM
 115 gdbscm_arch_p (SCM scm)
 116 {
 117   return scm_from_bool (arscm_is_arch (scm));
 118 }
 119
 120 /* Associates an arch_object with GDBARCH as gdbarch_data via the gdbarch
 121    post init registration mechanism (gdbarch_data_register_post_init).  */
 122
 123 static void *
 124 arscm_object_data_init (struct gdbarch *gdbarch)
 125 {
 126   SCM arch_scm = arscm_make_arch_smob (gdbarch);
 127
 128   /* This object lasts the duration of the GDB session, so there is no
 129      call to scm_gc_unprotect_object for it.  */
 130   scm_gc_protect_object (arch_scm);
 131
 132   return (void *) arch_scm;
 133 }
 134
 135 /* Return the <gdb:arch> object corresponding to GDBARCH.
 136    The object is cached in GDBARCH so this is simple.  */
 137
 138 SCM
 139 arscm_scm_from_arch (struct gdbarch *gdbarch)
 140 {
 141   SCM a_scm = (SCM) gdbarch_data (gdbarch, arch_object_data);
 142
 143   return a_scm;
 144 }
 145
 146 /* Return the <gdb:arch> smob in SELF.
 147    Throws an exception if SELF is not a <gdb:arch> object.  */
 148
 149 static SCM
 150 arscm_get_arch_arg_unsafe (SCM self, int arg_pos, const char *func_name)
 151 {
 152   SCM_ASSERT_TYPE (arscm_is_arch (self), self, arg_pos, func_name,
 153                    arch_smob_name);
 154
 155   return self;
 156 }
 157
 158 /* Return a pointer to the arch smob of SELF.
 159    Throws an exception if SELF is not a <gdb:arch> object.  */
 160
 161 arch_smob *
 162 arscm_get_arch_smob_arg_unsafe (SCM self, int arg_pos, const char *func_name)
 163 {
 164   SCM a_scm = arscm_get_arch_arg_unsafe (self, arg_pos, func_name);
 165   arch_smob *a_smob = (arch_smob *) SCM_SMOB_DATA (a_scm);
 166
 167   return a_smob;
 168 }
 169 \f
 170 /* Arch methods.  */
 171
 172 /* (current-arch) -> <gdb:arch>
 173    Return the architecture of the currently selected stack frame,
 174    if there is one, or the current target if there isn't.  */
 175
 176 static SCM
 177 gdbscm_current_arch (void)
 178 {
 179   return arscm_scm_from_arch (get_current_arch ());
 180 }
 181
 182 /* (arch-name <gdb:arch>) -> string
 183    Return the name of the architecture as a string value.  */
 184
 185 static SCM
 186 gdbscm_arch_name (SCM self)
 187 {
 188   arch_smob *a_smob
 189     = arscm_get_arch_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 190   struct gdbarch *gdbarch = a_smob->gdbarch;
 191   const char *name;
 192
 193   name = (gdbarch_bfd_arch_info (gdbarch))->printable_name;
 194
 195   return gdbscm_scm_from_c_string (name);
 196 }
 197
 198 /* (arch-charset <gdb:arch>) -> string */
 199
 200 static SCM
 201 gdbscm_arch_charset (SCM self)
 202 {
 203   arch_smob *a_smob
 204     =arscm_get_arch_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 205   struct gdbarch *gdbarch = a_smob->gdbarch;
 206
 207   return gdbscm_scm_from_c_string (target_charset (gdbarch));
 208 }
 209
 210 /* (arch-wide-charset <gdb:arch>) -> string */
 211
 212 static SCM
 213 gdbscm_arch_wide_charset (SCM self)
 214 {
 215   arch_smob *a_smob
 216     = arscm_get_arch_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 217   struct gdbarch *gdbarch = a_smob->gdbarch;
 218
 219   return gdbscm_scm_from_c_string (target_wide_charset (gdbarch));
 220 }
 221 \f
 222 /* Builtin types.
 223
 224    The order the types are defined here follows the order in
 225    struct builtin_type.  */
 226
 227 /* Helper routine to return a builtin type for <gdb:arch> object SELF.
 228    OFFSET is offsetof (builtin_type, the_type).
 229    Throws an exception if SELF is not a <gdb:arch> object.  */
 230
 231 static const struct builtin_type *
 232 gdbscm_arch_builtin_type (SCM self, const char *func_name)
 233 {
 234   arch_smob *a_smob
 235     = arscm_get_arch_smob_arg_unsafe (self, SCM_ARG1, func_name);
 236   struct gdbarch *gdbarch = a_smob->gdbarch;
 237
 238   return builtin_type (gdbarch);
 239 }
 240
 241 /* (arch-void-type <gdb:arch>) -> <gdb:type> */
 242
 243 static SCM
 244 gdbscm_arch_void_type (SCM self)
 245 {
 246   struct type *type
 247     = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_void;
 248
 249   return tyscm_scm_from_type (type);
 250 }
 251
 252 /* (arch-char-type <gdb:arch>) -> <gdb:type> */
 253
 254 static SCM
 255 gdbscm_arch_char_type (SCM self)
 256 {
 257   struct type *type
 258     = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_char;
 259
 260   return tyscm_scm_from_type (type);
 261 }
 262
 263 /* (arch-short-type <gdb:arch>) -> <gdb:type> */
 264
 265 static SCM
 266 gdbscm_arch_short_type (SCM self)
 267 {
 268   struct type *type
 269     = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_short;
 270
 271   return tyscm_scm_from_type (type);
 272 }
 273
 274 /* (arch-int-type <gdb:arch>) -> <gdb:type> */
 275
 276 static SCM
 277 gdbscm_arch_int_type (SCM self)
 278 {
 279   struct type *type
 280     = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_int;
 281
 282   return tyscm_scm_from_type (type);
 283 }
 284
 285 /* (arch-long-type <gdb:arch>) -> <gdb:type> */
 286
 287 static SCM
 288 gdbscm_arch_long_type (SCM self)
 289 {
 290   struct type *type
 291     = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_long;
 292
 293   return tyscm_scm_from_type (type);
 294 }
 295
 296 /* (arch-schar-type <gdb:arch>) -> <gdb:type> */
 297
 298 static SCM
 299 gdbscm_arch_schar_type (SCM self)
 300 {
 301   struct type *type
 302     = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_signed_char;
 303
 304   return tyscm_scm_from_type (type);
 305 }
 306
 307 /* (arch-uchar-type <gdb:arch>) -> <gdb:type> */
 308
 309 static SCM
 310 gdbscm_arch_uchar_type (SCM self)
 311 {
 312   struct type *type
 313     = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_unsigned_char;
 314
 315   return tyscm_scm_from_type (type);
 316 }
 317
 318 /* (arch-ushort-type <gdb:arch>) -> <gdb:type> */
 319
 320 static SCM
 321 gdbscm_arch_ushort_type (SCM self)
 322 {
 323   struct type *type
 324     = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_unsigned_short;
 325
 326   return tyscm_scm_from_type (type);
 327 }
 328
 329 /* (arch-uint-type <gdb:arch>) -> <gdb:type> */
 330
 331 static SCM
 332 gdbscm_arch_uint_type (SCM self)
 333 {
 334   struct type *type
 335     = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_unsigned_int;
 336
 337   return tyscm_scm_from_type (type);
 338 }
 339
 340 /* (arch-ulong-type <gdb:arch>) -> <gdb:type> */
 341
 342 static SCM
 343 gdbscm_arch_ulong_type (SCM self)
 344 {
 345   struct type *type
 346     = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_unsigned_long;
 347
 348   return tyscm_scm_from_type (type);
 349 }
 350
 351 /* (arch-float-type <gdb:arch>) -> <gdb:type> */
 352
 353 static SCM
 354 gdbscm_arch_float_type (SCM self)
 355 {
 356   struct type *type
 357     = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_float;
 358
 359   return tyscm_scm_from_type (type);
 360 }
 361
 362 /* (arch-double-type <gdb:arch>) -> <gdb:type> */
 363
 364 static SCM
 365 gdbscm_arch_double_type (SCM self)
 366 {
 367   struct type *type
 368     = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_double;
 369
 370   return tyscm_scm_from_type (type);
 371 }
 372
 373 /* (arch-longdouble-type <gdb:arch>) -> <gdb:type> */
 374
 375 static SCM
 376 gdbscm_arch_longdouble_type (SCM self)
 377 {
 378   struct type *type
 379     = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_long_double;
 380
 381   return tyscm_scm_from_type (type);
 382 }
 383
 384 /* (arch-bool-type <gdb:arch>) -> <gdb:type> */
 385
 386 static SCM
 387 gdbscm_arch_bool_type (SCM self)
 388 {
 389   struct type *type
 390     = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_bool;
 391
 392   return tyscm_scm_from_type (type);
 393 }
 394
 395 /* (arch-longlong-type <gdb:arch>) -> <gdb:type> */
 396
 397 static SCM
 398 gdbscm_arch_longlong_type (SCM self)
 399 {
 400   struct type *type
 401     = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_long_long;
 402
 403   return tyscm_scm_from_type (type);
 404 }
 405
 406 /* (arch-ulonglong-type <gdb:arch>) -> <gdb:type> */
 407
 408 static SCM
 409 gdbscm_arch_ulonglong_type (SCM self)
 410 {
 411   struct type *type
 412     = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_unsigned_long_long;
 413
 414   return tyscm_scm_from_type (type);
 415 }
 416
 417 /* (arch-int8-type <gdb:arch>) -> <gdb:type> */
 418
 419 static SCM
 420 gdbscm_arch_int8_type (SCM self)
 421 {
 422   struct type *type
 423     = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_int8;
 424
 425   return tyscm_scm_from_type (type);
 426 }
 427
 428 /* (arch-uint8-type <gdb:arch>) -> <gdb:type> */
 429
 430 static SCM
 431 gdbscm_arch_uint8_type (SCM self)
 432 {
 433   struct type *type
 434     = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_uint8;
 435
 436   return tyscm_scm_from_type (type);
 437 }
 438
 439 /* (arch-int16-type <gdb:arch>) -> <gdb:type> */
 440
 441 static SCM
 442 gdbscm_arch_int16_type (SCM self)
 443 {
 444   struct type *type
 445     = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_int16;
 446
 447   return tyscm_scm_from_type (type);
 448 }
 449
 450 /* (arch-uint16-type <gdb:arch>) -> <gdb:type> */
 451
 452 static SCM
 453 gdbscm_arch_uint16_type (SCM self)
 454 {
 455   struct type *type
 456     = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_uint16;
 457
 458   return tyscm_scm_from_type (type);
 459 }
 460
 461 /* (arch-int32-type <gdb:arch>) -> <gdb:type> */
 462
 463 static SCM
 464 gdbscm_arch_int32_type (SCM self)
 465 {
 466   struct type *type
 467     = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_int32;
 468
 469   return tyscm_scm_from_type (type);
 470 }
 471
 472 /* (arch-uint32-type <gdb:arch>) -> <gdb:type> */
 473
 474 static SCM
 475 gdbscm_arch_uint32_type (SCM self)
 476 {
 477   struct type *type
 478     = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_uint32;
 479
 480   return tyscm_scm_from_type (type);
 481 }
 482
 483 /* (arch-int64-type <gdb:arch>) -> <gdb:type> */
 484
 485 static SCM
 486 gdbscm_arch_int64_type (SCM self)
 487 {
 488   struct type *type
 489     = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_int64;
 490
 491   return tyscm_scm_from_type (type);
 492 }
 493
 494 /* (arch-uint64-type <gdb:arch>) -> <gdb:type> */
 495
 496 static SCM
 497 gdbscm_arch_uint64_type (SCM self)
 498 {
 499   struct type *type
 500     = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_uint64;
 501
 502   return tyscm_scm_from_type (type);
 503 }
 504 \f
 505 /* Initialize the Scheme architecture support.  */
 506
 507 static const scheme_function arch_functions[] =
 508 {
 509   { "arch?", 1, 0, 0, gdbscm_arch_p,
 510     "\
 511 Return #t if the object is a <gdb:arch> object." },
 512
 513   { "current-arch", 0, 0, 0, gdbscm_current_arch,
 514     "\
 515 Return the <gdb:arch> object representing the architecture of the\n\
 516 currently selected stack frame, if there is one, or the architecture of the\n\
 517 current target if there isn't.\n\
 518 \n\
 519   Arguments: none" },
 520
 521   { "arch-name", 1, 0, 0, gdbscm_arch_name,
 522     "\
 523 Return the name of the architecture." },
 524
 525   { "arch-charset", 1, 0, 0, gdbscm_arch_charset,
 526   "\
 527 Return name of target character set as a string." },
 528
 529   { "arch-wide-charset", 1, 0, 0, gdbscm_arch_wide_charset,
 530   "\
 531 Return name of target wide character set as a string." },
 532
 533   { "arch-void-type", 1, 0, 0, gdbscm_arch_void_type,
 534     "\
 535 Return the <gdb:type> object for the \"void\" type\n\
 536 of the architecture." },
 537
 538   { "arch-char-type", 1, 0, 0, gdbscm_arch_char_type,
 539     "\
 540 Return the <gdb:type> object for the \"char\" type\n\
 541 of the architecture." },
 542
 543   { "arch-short-type", 1, 0, 0, gdbscm_arch_short_type,
 544     "\
 545 Return the <gdb:type> object for the \"short\" type\n\
 546 of the architecture." },
 547
 548   { "arch-int-type", 1, 0, 0, gdbscm_arch_int_type,
 549     "\
 550 Return the <gdb:type> object for the \"int\" type\n\
 551 of the architecture." },
 552
 553   { "arch-long-type", 1, 0, 0, gdbscm_arch_long_type,
 554     "\
 555 Return the <gdb:type> object for the \"long\" type\n\
 556 of the architecture." },
 557
 558   { "arch-schar-type", 1, 0, 0, gdbscm_arch_schar_type,
 559     "\
 560 Return the <gdb:type> object for the \"signed char\" type\n\
 561 of the architecture." },
 562
 563   { "arch-uchar-type", 1, 0, 0, gdbscm_arch_uchar_type,
 564     "\
 565 Return the <gdb:type> object for the \"unsigned char\" type\n\
 566 of the architecture." },
 567
 568   { "arch-ushort-type", 1, 0, 0, gdbscm_arch_ushort_type,
 569     "\
 570 Return the <gdb:type> object for the \"unsigned short\" type\n\
 571 of the architecture." },
 572
 573   { "arch-uint-type", 1, 0, 0, gdbscm_arch_uint_type,
 574     "\
 575 Return the <gdb:type> object for the \"unsigned int\" type\n\
 576 of the architecture." },
 577
 578   { "arch-ulong-type", 1, 0, 0, gdbscm_arch_ulong_type,
 579     "\
 580 Return the <gdb:type> object for the \"unsigned long\" type\n\
 581 of the architecture." },
 582
 583   { "arch-float-type", 1, 0, 0, gdbscm_arch_float_type,
 584     "\
 585 Return the <gdb:type> object for the \"float\" type\n\
 586 of the architecture." },
 587
 588   { "arch-double-type", 1, 0, 0, gdbscm_arch_double_type,
 589     "\
 590 Return the <gdb:type> object for the \"double\" type\n\
 591 of the architecture." },
 592
 593   { "arch-longdouble-type", 1, 0, 0, gdbscm_arch_longdouble_type,
 594     "\
 595 Return the <gdb:type> object for the \"long double\" type\n\
 596 of the architecture." },
 597
 598   { "arch-bool-type", 1, 0, 0, gdbscm_arch_bool_type,
 599     "\
 600 Return the <gdb:type> object for the \"bool\" type\n\
 601 of the architecture." },
 602
 603   { "arch-longlong-type", 1, 0, 0, gdbscm_arch_longlong_type,
 604     "\
 605 Return the <gdb:type> object for the \"long long\" type\n\
 606 of the architecture." },
 607
 608   { "arch-ulonglong-type", 1, 0, 0,
 609     gdbscm_arch_ulonglong_type,
 610     "\
 611 Return the <gdb:type> object for the \"unsigned long long\" type\n\
 612 of the architecture." },
 613
 614   { "arch-int8-type", 1, 0, 0, gdbscm_arch_int8_type,
 615     "\
 616 Return the <gdb:type> object for the \"int8\" type\n\
 617 of the architecture." },
 618
 619   { "arch-uint8-type", 1, 0, 0, gdbscm_arch_uint8_type,
 620     "\
 621 Return the <gdb:type> object for the \"uint8\" type\n\
 622 of the architecture." },
 623
 624   { "arch-int16-type", 1, 0, 0, gdbscm_arch_int16_type,
 625     "\
 626 Return the <gdb:type> object for the \"int16\" type\n\
 627 of the architecture." },
 628
 629   { "arch-uint16-type", 1, 0, 0, gdbscm_arch_uint16_type,
 630     "\
 631 Return the <gdb:type> object for the \"uint16\" type\n\
 632 of the architecture." },
 633
 634   { "arch-int32-type", 1, 0, 0, gdbscm_arch_int32_type,
 635     "\
 636 Return the <gdb:type> object for the \"int32\" type\n\
 637 of the architecture." },
 638
 639   { "arch-uint32-type", 1, 0, 0, gdbscm_arch_uint32_type,
 640     "\
 641 Return the <gdb:type> object for the \"uint32\" type\n\
 642 of the architecture." },
 643
 644   { "arch-int64-type", 1, 0, 0, gdbscm_arch_int64_type,
 645     "\
 646 Return the <gdb:type> object for the \"int64\" type\n\
 647 of the architecture." },
 648
 649   { "arch-uint64-type", 1, 0, 0, gdbscm_arch_uint64_type,
 650     "\
 651 Return the <gdb:type> object for the \"uint64\" type\n\
 652 of the architecture." },
 653
 654   END_FUNCTIONS
 655 };
 656
 657 void
 658 gdbscm_initialize_arches (void)
 659 {
 660   arch_smob_tag = gdbscm_make_smob_type (arch_smob_name, sizeof (arch_smob));
 661   scm_set_smob_mark (arch_smob_tag, arscm_mark_arch_smob);
 662   scm_set_smob_print (arch_smob_tag, arscm_print_arch_smob);
 663
 664   gdbscm_define_functions (arch_functions, 1);
 665
 666   arch_object_data
 667     = gdbarch_data_register_post_init (arscm_object_data_init);
 668 }