gdb/guile/scm-utils.c

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