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