1 /* Scheme interface to architecture. 2 3 Copyright (C) 2014-2023 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 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 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 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 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 } 655