gdb/guile/scm-arch.c

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