gdb/guile/scm-utils.c

   1 /* General utility routines for GDB/Scheme code.
   2
   3    Copyright (C) 2014-2019 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
  28 void
  29 gdbscm_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
  43 void
  44 gdbscm_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
  62 void
  63 gdbscm_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 \f
  76 /* scm_printf, alas it doesn't exist.  */
  77
  78 void
  79 gdbscm_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
  91 void
  92 gdbscm_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
 103 void
 104 gdbscm_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 \f
 113 /* Subroutine of gdbscm_parse_function_args to simplify it.
 114    Return the number of keyword arguments.  */
 115
 116 static int
 117 count_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
 133 static int
 134 validate_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
 194 static SCM
 195 extract_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
 292 static int
 293 lookup_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
 313 static SCM
 314 gdbscm_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
 527 void
 528 gdbscm_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 \f
 543 /* Return longest L as a scheme object.  */
 544
 545 SCM
 546 gdbscm_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
 556 LONGEST
 557 gdbscm_scm_to_longest (SCM l)
 558 {
 559   return scm_to_int64 (l);
 560 }
 561
 562 /* Return unsigned longest L as a scheme object.  */
 563
 564 SCM
 565 gdbscm_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
 575 ULONGEST
 576 gdbscm_scm_to_ulongest (SCM u)
 577 {
 578   return scm_to_uint64 (u);
 579 }
 580
 581 /* Same as scm_dynwind_free, but uses xfree.  */
 582
 583 void
 584 gdbscm_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
 591 int
 592 gdbscm_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
 599 char *
 600 gdbscm_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
 612 const char * const *
 613 gdbscm_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
 643 int
 644 gdbscm_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 }