1 /* Scheme interface to architecture. 2 3 Copyright (C) 2014-2024 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 "charset.h" 24 #include "gdbarch.h" 25 #include "arch-utils.h" 26 #include "guile-internal.h" 27 28 /* The <gdb:arch> smob. */ 29 30 struct arch_smob 31 { 32 /* This always appears first. */ 33 gdb_smob base; 34 35 struct gdbarch *gdbarch; 36 }; 37 38 static const char arch_smob_name[] = "gdb:arch"; 39 40 /* The tag Guile knows the arch smob by. */ 41 static scm_t_bits arch_smob_tag; 42 43 /* Use a 'void *' here because it isn't guaranteed that SCM is a 44 pointer. */ 45 static const registry<gdbarch>::key<void, gdb::noop_deleter<void>> 46 arch_object_data; 47 48 static int arscm_is_arch (SCM); 49 50 /* Administrivia for arch smobs. */ 51 52 /* The smob "print" function for <gdb:arch>. */ 53 54 static int 55 arscm_print_arch_smob (SCM self, SCM port, scm_print_state *pstate) 56 { 57 arch_smob *a_smob = (arch_smob *) SCM_SMOB_DATA (self); 58 struct gdbarch *gdbarch = a_smob->gdbarch; 59 60 gdbscm_printf (port, "#<%s", arch_smob_name); 61 gdbscm_printf (port, " %s", gdbarch_bfd_arch_info (gdbarch)->printable_name); 62 scm_puts (">", port); 63 64 scm_remember_upto_here_1 (self); 65 66 /* Non-zero means success. */ 67 return 1; 68 } 69 70 /* Low level routine to create a <gdb:arch> object for GDBARCH. */ 71 72 static SCM 73 arscm_make_arch_smob (struct gdbarch *gdbarch) 74 { 75 arch_smob *a_smob = (arch_smob *) 76 scm_gc_malloc (sizeof (arch_smob), arch_smob_name); 77 SCM a_scm; 78 79 a_smob->gdbarch = gdbarch; 80 a_scm = scm_new_smob (arch_smob_tag, (scm_t_bits) a_smob); 81 gdbscm_init_gsmob (&a_smob->base); 82 83 return a_scm; 84 } 85 86 /* Return the gdbarch field of A_SMOB. */ 87 88 struct gdbarch * 89 arscm_get_gdbarch (arch_smob *a_smob) 90 { 91 return a_smob->gdbarch; 92 } 93 94 /* Return non-zero if SCM is an architecture smob. */ 95 96 static int 97 arscm_is_arch (SCM scm) 98 { 99 return SCM_SMOB_PREDICATE (arch_smob_tag, scm); 100 } 101 102 /* (arch? object) -> boolean */ 103 104 static SCM 105 gdbscm_arch_p (SCM scm) 106 { 107 return scm_from_bool (arscm_is_arch (scm)); 108 } 109 110 /* Return the <gdb:arch> object corresponding to GDBARCH. 111 The object is cached in GDBARCH so this is simple. */ 112 113 SCM 114 arscm_scm_from_arch (struct gdbarch *gdbarch) 115 { 116 SCM arch_scm; 117 void *data = arch_object_data.get (gdbarch); 118 if (data == nullptr) 119 { 120 arch_scm = arscm_make_arch_smob (gdbarch); 121 122 /* This object lasts the duration of the GDB session, so there 123 is no call to scm_gc_unprotect_object for it. */ 124 scm_gc_protect_object (arch_scm); 125 126 arch_object_data.set (gdbarch, (void *) arch_scm); 127 } 128 else 129 arch_scm = (SCM) data; 130 131 return arch_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 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 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 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