gdb/guile/scm-arch.c

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