1/* General utility routines for GDB/Scheme code. 2 3 Copyright (C) 2014-2020 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 "guile-internal.h" 25 26/* Define VARIABLES in the gdb module. */ 27 28void 29gdbscm_define_variables (const scheme_variable *variables, int is_public) 30{ 31 const scheme_variable *sv; 32 33 for (sv = variables; sv->name != NULL; ++sv) 34 { 35 scm_c_define (sv->name, sv->value); 36 if (is_public) 37 scm_c_export (sv->name, NULL); 38 } 39} 40 41/* Define FUNCTIONS in the gdb module. */ 42 43void 44gdbscm_define_functions (const scheme_function *functions, int is_public) 45{ 46 const scheme_function *sf; 47 48 for (sf = functions; sf->name != NULL; ++sf) 49 { 50 SCM proc = scm_c_define_gsubr (sf->name, sf->required, sf->optional, 51 sf->rest, sf->func); 52 53 scm_set_procedure_property_x (proc, gdbscm_documentation_symbol, 54 gdbscm_scm_from_c_string (sf->doc_string)); 55 if (is_public) 56 scm_c_export (sf->name, NULL); 57 } 58} 59 60/* Define CONSTANTS in the gdb module. */ 61 62void 63gdbscm_define_integer_constants (const scheme_integer_constant *constants, 64 int is_public) 65{ 66 const scheme_integer_constant *sc; 67 68 for (sc = constants; sc->name != NULL; ++sc) 69 { 70 scm_c_define (sc->name, scm_from_int (sc->value)); 71 if (is_public) 72 scm_c_export (sc->name, NULL); 73 } 74} 75 76/* scm_printf, alas it doesn't exist. */ 77 78void 79gdbscm_printf (SCM port, const char *format, ...) 80{ 81 va_list args; 82 83 va_start (args, format); 84 std::string string = string_vprintf (format, args); 85 va_end (args); 86 scm_puts (string.c_str (), port); 87} 88 89/* Utility for calling from gdb to "display" an SCM object. */ 90 91void 92gdbscm_debug_display (SCM obj) 93{ 94 SCM port = scm_current_output_port (); 95 96 scm_display (obj, port); 97 scm_newline (port); 98 scm_force_output (port); 99} 100 101/* Utility for calling from gdb to "write" an SCM object. */ 102 103void 104gdbscm_debug_write (SCM obj) 105{ 106 SCM port = scm_current_output_port (); 107 108 scm_write (obj, port); 109 scm_newline (port); 110 scm_force_output (port); 111} 112 113/* Subroutine of gdbscm_parse_function_args to simplify it. 114 Return the number of keyword arguments. */ 115 116static int 117count_keywords (const SCM *keywords) 118{ 119 int i; 120 121 if (keywords == NULL) 122 return 0; 123 for (i = 0; keywords[i] != SCM_BOOL_F; ++i) 124 continue; 125 126 return i; 127} 128 129/* Subroutine of gdbscm_parse_function_args to simplify it. 130 Validate an argument format string. 131 The result is a boolean indicating if "." was seen. */ 132 133static int 134validate_arg_format (const char *format) 135{ 136 const char *p; 137 int length = strlen (format); 138 int optional_position = -1; 139 int keyword_position = -1; 140 int dot_seen = 0; 141 142 gdb_assert (length > 0); 143 144 for (p = format; *p != '\0'; ++p) 145 { 146 switch (*p) 147 { 148 case 's': 149 case 't': 150 case 'i': 151 case 'u': 152 case 'l': 153 case 'n': 154 case 'L': 155 case 'U': 156 case 'O': 157 break; 158 case '|': 159 gdb_assert (keyword_position < 0); 160 gdb_assert (optional_position < 0); 161 optional_position = p - format; 162 break; 163 case '#': 164 gdb_assert (keyword_position < 0); 165 keyword_position = p - format; 166 break; 167 case '.': 168 gdb_assert (p[1] == '\0'); 169 dot_seen = 1; 170 break; 171 default: 172 gdb_assert_not_reached ("invalid argument format character"); 173 } 174 } 175 176 return dot_seen; 177} 178 179/* Our version of SCM_ASSERT_TYPE that calls gdbscm_make_type_error. */ 180#define CHECK_TYPE(ok, arg, position, func_name, expected_type) \ 181 do { \ 182 if (!(ok)) \ 183 { \ 184 return gdbscm_make_type_error ((func_name), (position), (arg), \ 185 (expected_type)); \ 186 } \ 187 } while (0) 188 189/* Subroutine of gdbscm_parse_function_args to simplify it. 190 Check the type of ARG against FORMAT_CHAR and extract the value. 191 POSITION is the position of ARG in the argument list. 192 The result is #f upon success or a <gdb:exception> object. */ 193 194static SCM 195extract_arg (char format_char, SCM arg, void *argp, 196 const char *func_name, int position) 197{ 198 switch (format_char) 199 { 200 case 's': 201 { 202 char **arg_ptr = (char **) argp; 203 204 CHECK_TYPE (gdbscm_is_true (scm_string_p (arg)), arg, position, 205 func_name, _("string")); 206 *arg_ptr = gdbscm_scm_to_c_string (arg).release (); 207 break; 208 } 209 case 't': 210 { 211 int *arg_ptr = (int *) argp; 212 213 /* While in Scheme, anything non-#f is "true", we're strict. */ 214 CHECK_TYPE (gdbscm_is_bool (arg), arg, position, func_name, 215 _("boolean")); 216 *arg_ptr = gdbscm_is_true (arg); 217 break; 218 } 219 case 'i': 220 { 221 int *arg_ptr = (int *) argp; 222 223 CHECK_TYPE (scm_is_signed_integer (arg, INT_MIN, INT_MAX), 224 arg, position, func_name, _("int")); 225 *arg_ptr = scm_to_int (arg); 226 break; 227 } 228 case 'u': 229 { 230 int *arg_ptr = (int *) argp; 231 232 CHECK_TYPE (scm_is_unsigned_integer (arg, 0, UINT_MAX), 233 arg, position, func_name, _("unsigned int")); 234 *arg_ptr = scm_to_uint (arg); 235 break; 236 } 237 case 'l': 238 { 239 long *arg_ptr = (long *) argp; 240 241 CHECK_TYPE (scm_is_signed_integer (arg, LONG_MIN, LONG_MAX), 242 arg, position, func_name, _("long")); 243 *arg_ptr = scm_to_long (arg); 244 break; 245 } 246 case 'n': 247 { 248 unsigned long *arg_ptr = (unsigned long *) argp; 249 250 CHECK_TYPE (scm_is_unsigned_integer (arg, 0, ULONG_MAX), 251 arg, position, func_name, _("unsigned long")); 252 *arg_ptr = scm_to_ulong (arg); 253 break; 254 } 255 case 'L': 256 { 257 LONGEST *arg_ptr = (LONGEST *) argp; 258 259 CHECK_TYPE (scm_is_signed_integer (arg, INT64_MIN, INT64_MAX), 260 arg, position, func_name, _("LONGEST")); 261 *arg_ptr = gdbscm_scm_to_longest (arg); 262 break; 263 } 264 case 'U': 265 { 266 ULONGEST *arg_ptr = (ULONGEST *) argp; 267 268 CHECK_TYPE (scm_is_unsigned_integer (arg, 0, UINT64_MAX), 269 arg, position, func_name, _("ULONGEST")); 270 *arg_ptr = gdbscm_scm_to_ulongest (arg); 271 break; 272 } 273 case 'O': 274 { 275 SCM *arg_ptr = (SCM *) argp; 276 277 *arg_ptr = arg; 278 break; 279 } 280 default: 281 gdb_assert_not_reached ("invalid argument format character"); 282 } 283 284 return SCM_BOOL_F; 285} 286 287#undef CHECK_TYPE 288 289/* Look up KEYWORD in KEYWORD_LIST. 290 The result is the index of the keyword in the list or -1 if not found. */ 291 292static int 293lookup_keyword (const SCM *keyword_list, SCM keyword) 294{ 295 int i = 0; 296 297 while (keyword_list[i] != SCM_BOOL_F) 298 { 299 if (scm_is_eq (keyword_list[i], keyword)) 300 return i; 301 ++i; 302 } 303 304 return -1; 305} 306 307 308/* Helper for gdbscm_parse_function_args that does most of the work, 309 in a separate function wrapped with gdbscm_wrap so that we can use 310 non-trivial-dtor objects here. The result is #f upon success or a 311 <gdb:exception> object otherwise. */ 312 313static SCM 314gdbscm_parse_function_args_1 (const char *func_name, 315 int beginning_arg_pos, 316 const SCM *keywords, 317 const char *format, va_list args) 318{ 319 const char *p; 320 int i, have_rest, num_keywords, position; 321 int have_optional = 0; 322 SCM status; 323 SCM rest = SCM_EOL; 324 /* Keep track of malloc'd strings. We need to free them upon error. */ 325 std::vector<char *> allocated_strings; 326 327 have_rest = validate_arg_format (format); 328 num_keywords = count_keywords (keywords); 329 330 p = format; 331 position = beginning_arg_pos; 332 333 /* Process required, optional arguments. */ 334 335 while (*p && *p != '#' && *p != '.') 336 { 337 SCM arg; 338 void *arg_ptr; 339 340 if (*p == '|') 341 { 342 have_optional = 1; 343 ++p; 344 continue; 345 } 346 347 arg = va_arg (args, SCM); 348 if (!have_optional || !SCM_UNBNDP (arg)) 349 { 350 arg_ptr = va_arg (args, void *); 351 status = extract_arg (*p, arg, arg_ptr, func_name, position); 352 if (!gdbscm_is_false (status)) 353 goto fail; 354 if (*p == 's') 355 allocated_strings.push_back (*(char **) arg_ptr); 356 } 357 ++p; 358 ++position; 359 } 360 361 /* Process keyword arguments. */ 362 363 if (have_rest || num_keywords > 0) 364 rest = va_arg (args, SCM); 365 366 if (num_keywords > 0) 367 { 368 SCM *keyword_args = XALLOCAVEC (SCM, num_keywords); 369 int *keyword_positions = XALLOCAVEC (int, num_keywords); 370 371 gdb_assert (*p == '#'); 372 ++p; 373 374 for (i = 0; i < num_keywords; ++i) 375 { 376 keyword_args[i] = SCM_UNSPECIFIED; 377 keyword_positions[i] = -1; 378 } 379 380 while (scm_is_pair (rest) 381 && scm_is_keyword (scm_car (rest))) 382 { 383 SCM keyword = scm_car (rest); 384 385 i = lookup_keyword (keywords, keyword); 386 if (i < 0) 387 { 388 status = gdbscm_make_error (scm_arg_type_key, func_name, 389 _("Unrecognized keyword: ~a"), 390 scm_list_1 (keyword), keyword); 391 goto fail; 392 } 393 if (!scm_is_pair (scm_cdr (rest))) 394 { 395 status = gdbscm_make_error 396 (scm_arg_type_key, func_name, 397 _("Missing value for keyword argument"), 398 scm_list_1 (keyword), keyword); 399 goto fail; 400 } 401 keyword_args[i] = scm_cadr (rest); 402 keyword_positions[i] = position + 1; 403 rest = scm_cddr (rest); 404 position += 2; 405 } 406 407 for (i = 0; i < num_keywords; ++i) 408 { 409 int *arg_pos_ptr = va_arg (args, int *); 410 void *arg_ptr = va_arg (args, void *); 411 SCM arg = keyword_args[i]; 412 413 if (! scm_is_eq (arg, SCM_UNSPECIFIED)) 414 { 415 *arg_pos_ptr = keyword_positions[i]; 416 status = extract_arg (p[i], arg, arg_ptr, func_name, 417 keyword_positions[i]); 418 if (!gdbscm_is_false (status)) 419 goto fail; 420 if (p[i] == 's') 421 allocated_strings.push_back (*(char **) arg_ptr); 422 } 423 } 424 } 425 426 /* Process "rest" arguments. */ 427 428 if (have_rest) 429 { 430 if (num_keywords > 0) 431 { 432 SCM *rest_ptr = va_arg (args, SCM *); 433 434 *rest_ptr = rest; 435 } 436 } 437 else 438 { 439 if (! scm_is_null (rest)) 440 { 441 status = gdbscm_make_error (scm_args_number_key, func_name, 442 _("Too many arguments"), 443 SCM_EOL, SCM_BOOL_F); 444 goto fail; 445 } 446 } 447 448 /* Return anything not-an-exception. */ 449 return SCM_BOOL_F; 450 451 fail: 452 for (char *ptr : allocated_strings) 453 xfree (ptr); 454 455 /* Return the exception, which gdbscm_wrap takes care of 456 throwing. */ 457 return status; 458} 459 460/* Utility to parse required, optional, and keyword arguments to Scheme 461 functions. Modelled on PyArg_ParseTupleAndKeywords, but no attempt is made 462 at similarity or functionality. 463 There is no result, if there's an error a Scheme exception is thrown. 464 465 Guile provides scm_c_bind_keyword_arguments, and feel free to use it. 466 This is for times when we want a bit more parsing. 467 468 BEGINNING_ARG_POS is the position of the first argument passed to this 469 routine. It should be one of the SCM_ARGn values. It could be > SCM_ARG1 470 if the caller chooses not to parse one or more required arguments. 471 472 KEYWORDS may be NULL if there are no keywords. 473 474 FORMAT: 475 s - string -> char *, malloc'd 476 t - boolean (gdb uses "t", for biT?) -> int 477 i - int 478 u - unsigned int 479 l - long 480 n - unsigned long 481 L - longest 482 U - unsigned longest 483 O - random scheme object 484 | - indicates the next set is for optional arguments 485 # - indicates the next set is for keyword arguments (must follow |) 486 . - indicates "rest" arguments are present, this character must appear last 487 488 FORMAT must match the definition from scm_c_{make,define}_gsubr. 489 Required and optional arguments appear in order in the format string. 490 Afterwards, keyword-based arguments are processed. There must be as many 491 remaining characters in the format string as their are keywords. 492 Except for "|#.", the number of characters in the format string must match 493 #required + #optional + #keywords. 494 495 The function is required to be defined in a compatible manner: 496 #required-args and #optional-arguments must match, and rest-arguments 497 must be specified if keyword args are desired, and/or regular "rest" args. 498 499 Example: For this function, 500 scm_c_define_gsubr ("execute", 2, 3, 1, foo); 501 the format string + keyword list could be any of: 502 1) "ss|ttt#tt", { "key1", "key2", NULL } 503 2) "ss|ttt.", { NULL } 504 3) "ss|ttt#t.", { "key1", NULL } 505 506 For required and optional args pass the SCM of the argument, and a 507 pointer to the value to hold the parsed result (type depends on format 508 char). After that pass the SCM containing the "rest" arguments followed 509 by pointers to values to hold parsed keyword arguments, and if specified 510 a pointer to hold the remaining contents of "rest". 511 512 For keyword arguments pass two pointers: the first is a pointer to an int 513 that will contain the position of the argument in the arg list, and the 514 second will contain result of processing the argument. The int pointed 515 to by the first value should be initialized to -1. It can then be used 516 to tell whether the keyword was present. 517 518 If both keyword and rest arguments are present, the caller must pass a 519 pointer to contain the new value of rest (after keyword args have been 520 removed). 521 522 There's currently no way, that I know of, to specify default values for 523 optional arguments in C-provided functions. At the moment they're a 524 work-in-progress. The caller should test SCM_UNBNDP for each optional 525 argument. Unbound optional arguments are ignored. */ 526 527void 528gdbscm_parse_function_args (const char *func_name, 529 int beginning_arg_pos, 530 const SCM *keywords, 531 const char *format, ...) 532{ 533 va_list args; 534 va_start (args, format); 535 536 gdbscm_wrap (gdbscm_parse_function_args_1, func_name, 537 beginning_arg_pos, keywords, format, args); 538 539 va_end (args); 540} 541 542 543/* Return longest L as a scheme object. */ 544 545SCM 546gdbscm_scm_from_longest (LONGEST l) 547{ 548 return scm_from_int64 (l); 549} 550 551/* Convert scheme object L to LONGEST. 552 It is an error to call this if L is not an integer in range of LONGEST. 553 (because the underlying Scheme function will thrown an exception, 554 which is not part of our contract with the caller). */ 555 556LONGEST 557gdbscm_scm_to_longest (SCM l) 558{ 559 return scm_to_int64 (l); 560} 561 562/* Return unsigned longest L as a scheme object. */ 563 564SCM 565gdbscm_scm_from_ulongest (ULONGEST l) 566{ 567 return scm_from_uint64 (l); 568} 569 570/* Convert scheme object U to ULONGEST. 571 It is an error to call this if U is not an integer in range of ULONGEST 572 (because the underlying Scheme function will thrown an exception, 573 which is not part of our contract with the caller). */ 574 575ULONGEST 576gdbscm_scm_to_ulongest (SCM u) 577{ 578 return scm_to_uint64 (u); 579} 580 581/* Same as scm_dynwind_free, but uses xfree. */ 582 583void 584gdbscm_dynwind_xfree (void *ptr) 585{ 586 scm_dynwind_unwind_handler (xfree, ptr, SCM_F_WIND_EXPLICITLY); 587} 588 589/* Return non-zero if PROC is a procedure. */ 590 591int 592gdbscm_is_procedure (SCM proc) 593{ 594 return gdbscm_is_true (scm_procedure_p (proc)); 595} 596 597/* Same as xstrdup, but the string is allocated on the GC heap. */ 598 599char * 600gdbscm_gc_xstrdup (const char *str) 601{ 602 size_t len = strlen (str); 603 char *result 604 = (char *) scm_gc_malloc_pointerless (len + 1, "gdbscm_gc_xstrdup"); 605 606 strcpy (result, str); 607 return result; 608} 609 610/* Return a duplicate of ARGV living on the GC heap. */ 611 612const char * const * 613gdbscm_gc_dup_argv (char **argv) 614{ 615 int i, len; 616 size_t string_space; 617 char *p, **result; 618 619 for (len = 0, string_space = 0; argv[len] != NULL; ++len) 620 string_space += strlen (argv[len]) + 1; 621 622 /* Allocating "pointerless" works because the pointers are all 623 self-contained within the object. */ 624 result = (char **) scm_gc_malloc_pointerless (((len + 1) * sizeof (char *)) 625 + string_space, 626 "parameter enum list"); 627 p = (char *) &result[len + 1]; 628 629 for (i = 0; i < len; ++i) 630 { 631 result[i] = p; 632 strcpy (p, argv[i]); 633 p += strlen (p) + 1; 634 } 635 result[i] = NULL; 636 637 return (const char * const *) result; 638} 639 640/* Return non-zero if the version of Guile being used it at least 641 MAJOR.MINOR.MICRO. */ 642 643int 644gdbscm_guile_version_is_at_least (int major, int minor, int micro) 645{ 646 if (major > gdbscm_guile_major_version) 647 return 0; 648 if (major < gdbscm_guile_major_version) 649 return 1; 650 if (minor > gdbscm_guile_minor_version) 651 return 0; 652 if (minor < gdbscm_guile_minor_version) 653 return 1; 654 if (micro > gdbscm_guile_micro_version) 655 return 0; 656 return 1; 657} 658