gdb/guile/scm-utils.c

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