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