gdb/guile/scm-param.c

   1 /* GDB parameters implemented in Guile.
   2
   3    Copyright (C) 2008-2022 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 #include "defs.h"
  21 #include "value.h"
  22 #include "charset.h"
  23 #include "gdbcmd.h"
  24 #include "cli/cli-decode.h"
  25 #include "completer.h"
  26 #include "language.h"
  27 #include "arch-utils.h"
  28 #include "guile-internal.h"
  29
  30 /* A union that can hold anything described by enum var_types.  */
  31
  32 union pascm_variable
  33 {
  34   /* Hold an boolean value.  */
  35   bool boolval;
  36
  37   /* Hold an integer value.  */
  38   int intval;
  39
  40   /* Hold an auto_boolean.  */
  41   enum auto_boolean autoboolval;
  42
  43   /* Hold an unsigned integer value, for uinteger.  */
  44   unsigned int uintval;
  45
  46   /* Hold a string, for the various string types.  */
  47   std::string *stringval;
  48
  49   /* Hold a string, for enums.  */
  50   const char *cstringval;
  51 };
  52
  53 /* A GDB parameter.
  54
  55    Note: Parameters are added to gdb using a two step process:
  56    1) Call make-parameter to create a <gdb:parameter> object.
  57    2) Call register-parameter! to add the parameter to gdb.
  58    It is done this way so that the constructor, make-parameter, doesn't have
  59    any side-effects.  This means that the smob needs to store everything
  60    that was passed to make-parameter.  */
  61
  62 struct param_smob
  63 {
  64   /* This always appears first.  */
  65   gdb_smob base;
  66
  67   /* The parameter name.  */
  68   char *name;
  69
  70   /* The last word of the command.
  71      This is needed because add_cmd requires us to allocate space
  72      for it. :-(  */
  73   char *cmd_name;
  74
  75   /* One of the COMMAND_* constants.  */
  76   enum command_class cmd_class;
  77
  78   /* The type of the parameter.  */
  79   enum var_types type;
  80
  81   /* The docs for the parameter.  */
  82   char *set_doc;
  83   char *show_doc;
  84   char *doc;
  85
  86   /* The corresponding gdb command objects.
  87      These are NULL if the parameter has not been registered yet, or
  88      is no longer registered.  */
  89   set_show_commands commands;
  90
  91   /* The value of the parameter.  */
  92   union pascm_variable value;
  93
  94   /* For an enum parameter, the possible values.  The vector lives in GC
  95      space, it will be freed with the smob.  */
  96   const char * const *enumeration;
  97
  98   /* The set_func funcion or #f if not specified.
  99      This function is called *after* the parameter is set.
 100      It returns a string that will be displayed to the user.  */
 101   SCM set_func;
 102
 103   /* The show_func function or #f if not specified.
 104      This function returns the string that is printed.  */
 105   SCM show_func;
 106
 107   /* The <gdb:parameter> object we are contained in, needed to
 108      protect/unprotect the object since a reference to it comes from
 109      non-gc-managed space (the command context pointer).  */
 110   SCM containing_scm;
 111 };
 112
 113 /* Wraps a setting around an existing param_smob.  This abstraction
 114    is used to manipulate the value in S->VALUE in a type safe manner using
 115    the setting interface.  */
 116
 117 static setting
 118 make_setting (param_smob *s)
 119 {
 120   if (var_type_uses<bool> (s->type))
 121     return setting (s->type, &s->value.boolval);
 122   else if (var_type_uses<int> (s->type))
 123     return setting (s->type, &s->value.intval);
 124   else if (var_type_uses<auto_boolean> (s->type))
 125     return setting (s->type, &s->value.autoboolval);
 126   else if (var_type_uses<unsigned int> (s->type))
 127     return setting (s->type, &s->value.uintval);
 128   else if (var_type_uses<std::string> (s->type))
 129     return setting (s->type, s->value.stringval);
 130   else if (var_type_uses<const char *> (s->type))
 131     return setting (s->type, &s->value.cstringval);
 132   else
 133     gdb_assert_not_reached ("unhandled var type");
 134 }
 135
 136 static const char param_smob_name[] = "gdb:parameter";
 137
 138 /* The tag Guile knows the param smob by.  */
 139 static scm_t_bits parameter_smob_tag;
 140
 141 /* Keywords used by make-parameter!.  */
 142 static SCM command_class_keyword;
 143 static SCM parameter_type_keyword;
 144 static SCM enum_list_keyword;
 145 static SCM set_func_keyword;
 146 static SCM show_func_keyword;
 147 static SCM doc_keyword;
 148 static SCM set_doc_keyword;
 149 static SCM show_doc_keyword;
 150 static SCM initial_value_keyword;
 151 static SCM auto_keyword;
 152 static SCM unlimited_keyword;
 153
 154 static int pascm_is_valid (param_smob *);
 155 static const char *pascm_param_type_name (enum var_types type);
 156 static SCM pascm_param_value (const setting &var, int arg_pos,
 157                               const char *func_name);
 158 \f
 159 /* Administrivia for parameter smobs.  */
 160
 161 static int
 162 pascm_print_param_smob (SCM self, SCM port, scm_print_state *pstate)
 163 {
 164   param_smob *p_smob = (param_smob *) SCM_SMOB_DATA (self);
 165   SCM value;
 166
 167   gdbscm_printf (port, "#<%s", param_smob_name);
 168
 169   gdbscm_printf (port, " %s", p_smob->name);
 170
 171   if (! pascm_is_valid (p_smob))
 172     scm_puts (" {invalid}", port);
 173
 174   gdbscm_printf (port, " %s ", pascm_param_type_name (p_smob->type));
 175
 176   value = pascm_param_value (make_setting (p_smob), GDBSCM_ARG_NONE, NULL);
 177   scm_display (value, port);
 178
 179   scm_puts (">", port);
 180
 181   scm_remember_upto_here_1 (self);
 182
 183   /* Non-zero means success.  */
 184   return 1;
 185 }
 186
 187 /* Create an empty (uninitialized) parameter.  */
 188
 189 static SCM
 190 pascm_make_param_smob (void)
 191 {
 192   param_smob *p_smob = (param_smob *)
 193     scm_gc_malloc (sizeof (param_smob), param_smob_name);
 194   SCM p_scm;
 195
 196   memset (p_smob, 0, sizeof (*p_smob));
 197   p_smob->cmd_class = no_class;
 198   p_smob->type = var_boolean; /* ARI: var_boolean */
 199   p_smob->set_func = SCM_BOOL_F;
 200   p_smob->show_func = SCM_BOOL_F;
 201   p_scm = scm_new_smob (parameter_smob_tag, (scm_t_bits) p_smob);
 202   p_smob->containing_scm = p_scm;
 203   gdbscm_init_gsmob (&p_smob->base);
 204
 205   return p_scm;
 206 }
 207
 208 /* Returns non-zero if SCM is a <gdb:parameter> object.  */
 209
 210 static int
 211 pascm_is_parameter (SCM scm)
 212 {
 213   return SCM_SMOB_PREDICATE (parameter_smob_tag, scm);
 214 }
 215
 216 /* (gdb:parameter? scm) -> boolean */
 217
 218 static SCM
 219 gdbscm_parameter_p (SCM scm)
 220 {
 221   return scm_from_bool (pascm_is_parameter (scm));
 222 }
 223
 224 /* Returns the <gdb:parameter> object in SELF.
 225    Throws an exception if SELF is not a <gdb:parameter> object.  */
 226
 227 static SCM
 228 pascm_get_param_arg_unsafe (SCM self, int arg_pos, const char *func_name)
 229 {
 230   SCM_ASSERT_TYPE (pascm_is_parameter (self), self, arg_pos, func_name,
 231                    param_smob_name);
 232
 233   return self;
 234 }
 235
 236 /* Returns a pointer to the parameter smob of SELF.
 237    Throws an exception if SELF is not a <gdb:parameter> object.  */
 238
 239 static param_smob *
 240 pascm_get_param_smob_arg_unsafe (SCM self, int arg_pos, const char *func_name)
 241 {
 242   SCM p_scm = pascm_get_param_arg_unsafe (self, arg_pos, func_name);
 243   param_smob *p_smob = (param_smob *) SCM_SMOB_DATA (p_scm);
 244
 245   return p_smob;
 246 }
 247
 248 /* Return non-zero if parameter P_SMOB is valid.  */
 249
 250 static int
 251 pascm_is_valid (param_smob *p_smob)
 252 {
 253   return p_smob->commands.set != nullptr;
 254 }
 255 \f
 256 /* A helper function which return the default documentation string for
 257    a parameter (which is to say that it's undocumented).  */
 258
 259 static char *
 260 get_doc_string (void)
 261 {
 262   return xstrdup (_("This command is not documented."));
 263 }
 264
 265 /* Subroutine of pascm_set_func, pascm_show_func to simplify them.
 266    Signal the error returned from calling set_func/show_func.  */
 267
 268 static void
 269 pascm_signal_setshow_error (SCM exception, const char *msg)
 270 {
 271   /* Don't print the stack if this was an error signalled by the command
 272      itself.  */
 273   if (gdbscm_user_error_p (gdbscm_exception_key (exception)))
 274     {
 275       gdb::unique_xmalloc_ptr<char> excp_text
 276         = gdbscm_exception_message_to_string (exception);
 277
 278       error ("%s", excp_text.get ());
 279     }
 280   else
 281     {
 282       gdbscm_print_gdb_exception (SCM_BOOL_F, exception);
 283       error ("%s", msg);
 284     }
 285 }
 286
 287 /* A callback function that is registered against the respective
 288    add_setshow_* set_func prototype.  This function will call
 289    the Scheme function "set_func" which must exist.
 290    Note: ARGS is always passed as NULL.  */
 291
 292 static void
 293 pascm_set_func (const char *args, int from_tty, struct cmd_list_element *c)
 294 {
 295   param_smob *p_smob = (param_smob *) c->context ();
 296   SCM self, result, exception;
 297
 298   gdb_assert (gdbscm_is_procedure (p_smob->set_func));
 299
 300   self = p_smob->containing_scm;
 301
 302   result = gdbscm_safe_call_1 (p_smob->set_func, self, gdbscm_user_error_p);
 303
 304   if (gdbscm_is_exception (result))
 305     {
 306       pascm_signal_setshow_error (result,
 307                                   _("Error occurred setting parameter."));
 308     }
 309
 310   if (!scm_is_string (result))
 311     error (_("Result of %s set-func is not a string."), p_smob->name);
 312
 313   gdb::unique_xmalloc_ptr<char> msg = gdbscm_scm_to_host_string (result, NULL,
 314                                                                  &exception);
 315   if (msg == NULL)
 316     {
 317       gdbscm_print_gdb_exception (SCM_BOOL_F, exception);
 318       error (_("Error converting show text to host string."));
 319     }
 320
 321   /* GDB is usually silent when a parameter is set.  */
 322   if (*msg.get () != '\0')
 323     gdb_printf ("%s\n", msg.get ());
 324 }
 325
 326 /* A callback function that is registered against the respective
 327    add_setshow_* show_func prototype.  This function will call
 328    the Scheme function "show_func" which must exist and must return a
 329    string that is then printed to FILE.  */
 330
 331 static void
 332 pascm_show_func (struct ui_file *file, int from_tty,
 333                  struct cmd_list_element *c, const char *value)
 334 {
 335   param_smob *p_smob = (param_smob *) c->context ();
 336   SCM value_scm, self, result, exception;
 337
 338   gdb_assert (gdbscm_is_procedure (p_smob->show_func));
 339
 340   value_scm = gdbscm_scm_from_host_string (value, strlen (value));
 341   if (gdbscm_is_exception (value_scm))
 342     {
 343       error (_("Error converting parameter value \"%s\" to Scheme string."),
 344              value);
 345     }
 346   self = p_smob->containing_scm;
 347
 348   result = gdbscm_safe_call_2 (p_smob->show_func, self, value_scm,
 349                                gdbscm_user_error_p);
 350
 351   if (gdbscm_is_exception (result))
 352     {
 353       pascm_signal_setshow_error (result,
 354                                   _("Error occurred showing parameter."));
 355     }
 356
 357   gdb::unique_xmalloc_ptr<char> msg = gdbscm_scm_to_host_string (result, NULL,
 358                                                                  &exception);
 359   if (msg == NULL)
 360     {
 361       gdbscm_print_gdb_exception (SCM_BOOL_F, exception);
 362       error (_("Error converting show text to host string."));
 363     }
 364
 365   gdb_printf (file, "%s\n", msg.get ());
 366 }
 367
 368 /* A helper function that dispatches to the appropriate add_setshow
 369    function.  */
 370
 371 static set_show_commands
 372 add_setshow_generic (enum var_types param_type, enum command_class cmd_class,
 373                      char *cmd_name, param_smob *self,
 374                      char *set_doc, char *show_doc, char *help_doc,
 375                      cmd_func_ftype *set_func,
 376                      show_value_ftype *show_func,
 377                      struct cmd_list_element **set_list,
 378                      struct cmd_list_element **show_list)
 379 {
 380   set_show_commands commands;
 381
 382   switch (param_type)
 383     {
 384     case var_boolean:
 385       commands = add_setshow_boolean_cmd (cmd_name, cmd_class,
 386                                           &self->value.boolval, set_doc,
 387                                           show_doc, help_doc, set_func,
 388                                           show_func, set_list, show_list);
 389       break;
 390
 391     case var_auto_boolean:
 392       commands = add_setshow_auto_boolean_cmd (cmd_name, cmd_class,
 393                                                &self->value.autoboolval,
 394                                                set_doc, show_doc, help_doc,
 395                                                set_func, show_func, set_list,
 396                                                show_list);
 397       break;
 398
 399     case var_uinteger:
 400       commands = add_setshow_uinteger_cmd (cmd_name, cmd_class,
 401                                            &self->value.uintval, set_doc,
 402                                            show_doc, help_doc, set_func,
 403                                            show_func, set_list, show_list);
 404       break;
 405
 406     case var_zinteger:
 407       commands = add_setshow_zinteger_cmd (cmd_name, cmd_class,
 408                                            &self->value.intval, set_doc,
 409                                            show_doc, help_doc, set_func,
 410                                            show_func, set_list, show_list);
 411       break;
 412
 413     case var_zuinteger:
 414       commands = add_setshow_zuinteger_cmd (cmd_name, cmd_class,
 415                                             &self->value.uintval, set_doc,
 416                                             show_doc, help_doc, set_func,
 417                                             show_func, set_list, show_list);
 418       break;
 419
 420     case var_zuinteger_unlimited:
 421       commands = add_setshow_zuinteger_unlimited_cmd (cmd_name, cmd_class,
 422                                                       &self->value.intval,
 423                                                       set_doc, show_doc,
 424                                                       help_doc, set_func,
 425                                                       show_func, set_list,
 426                                                       show_list);
 427       break;
 428
 429     case var_string:
 430       commands = add_setshow_string_cmd (cmd_name, cmd_class,
 431                                          self->value.stringval, set_doc,
 432                                          show_doc, help_doc, set_func,
 433                                          show_func, set_list, show_list);
 434       break;
 435
 436     case var_string_noescape:
 437       commands = add_setshow_string_noescape_cmd (cmd_name, cmd_class,
 438                                                   self->value.stringval,
 439                                                   set_doc, show_doc, help_doc,
 440                                                   set_func, show_func, set_list,
 441                                                   show_list);
 442
 443       break;
 444
 445     case var_optional_filename:
 446       commands = add_setshow_optional_filename_cmd (cmd_name, cmd_class,
 447                                                     self->value.stringval,
 448                                                     set_doc, show_doc, help_doc,
 449                                                     set_func, show_func,
 450                                                     set_list, show_list);
 451       break;
 452
 453     case var_filename:
 454       commands = add_setshow_filename_cmd (cmd_name, cmd_class,
 455                                            self->value.stringval, set_doc,
 456                                            show_doc, help_doc, set_func,
 457                                            show_func, set_list, show_list);
 458       break;
 459
 460     case var_enum:
 461       /* Initialize the value, just in case.  */
 462       make_setting (self).set<const char *> (self->enumeration[0]);
 463       commands = add_setshow_enum_cmd (cmd_name, cmd_class, self->enumeration,
 464                                        &self->value.cstringval, set_doc,
 465                                        show_doc, help_doc, set_func, show_func,
 466                                        set_list, show_list);
 467       break;
 468
 469     default:
 470       gdb_assert_not_reached ("bad param_type value");
 471     }
 472
 473   /* Register Scheme object against the commandsparameter context.  Perform this
 474      task against both lists.  */
 475   commands.set->set_context (self);
 476   commands.show->set_context (self);
 477
 478   return commands;
 479 }
 480
 481 /* Return an array of strings corresponding to the enum values for
 482    ENUM_VALUES_SCM.
 483    Throws an exception if there's a problem with the values.
 484    Space for the result is allocated from the GC heap.  */
 485
 486 static const char * const *
 487 compute_enum_list (SCM enum_values_scm, int arg_pos, const char *func_name)
 488 {
 489   long i, size;
 490   char **enum_values;
 491   const char * const *result;
 492
 493   SCM_ASSERT_TYPE (gdbscm_is_true (scm_list_p (enum_values_scm)),
 494                    enum_values_scm, arg_pos, func_name, _("list"));
 495
 496   size = scm_ilength (enum_values_scm);
 497   if (size == 0)
 498     {
 499       gdbscm_out_of_range_error (FUNC_NAME, arg_pos, enum_values_scm,
 500                                  _("enumeration list is empty"));
 501     }
 502
 503   enum_values = XCNEWVEC (char *, size + 1);
 504
 505   i = 0;
 506   while (!scm_is_eq (enum_values_scm, SCM_EOL))
 507     {
 508       SCM value = scm_car (enum_values_scm);
 509       SCM exception;
 510
 511       if (!scm_is_string (value))
 512         {
 513           freeargv (enum_values);
 514           SCM_ASSERT_TYPE (0, value, arg_pos, func_name, _("string"));
 515         }
 516       enum_values[i] = gdbscm_scm_to_host_string (value, NULL,
 517                                                   &exception).release ();
 518       if (enum_values[i] == NULL)
 519         {
 520           freeargv (enum_values);
 521           gdbscm_throw (exception);
 522         }
 523       ++i;
 524       enum_values_scm = scm_cdr (enum_values_scm);
 525     }
 526   gdb_assert (i == size);
 527
 528   result = gdbscm_gc_dup_argv (enum_values);
 529   freeargv (enum_values);
 530   return result;
 531 }
 532
 533 static const scheme_integer_constant parameter_types[] =
 534 {
 535   /* Note: var_integer is deprecated, and intentionally does not
 536      appear here.  */
 537   { "PARAM_BOOLEAN", var_boolean }, /* ARI: var_boolean */
 538   { "PARAM_AUTO_BOOLEAN", var_auto_boolean },
 539   { "PARAM_ZINTEGER", var_zinteger },
 540   { "PARAM_UINTEGER", var_uinteger },
 541   { "PARAM_ZUINTEGER", var_zuinteger },
 542   { "PARAM_ZUINTEGER_UNLIMITED", var_zuinteger_unlimited },
 543   { "PARAM_STRING", var_string },
 544   { "PARAM_STRING_NOESCAPE", var_string_noescape },
 545   { "PARAM_OPTIONAL_FILENAME", var_optional_filename },
 546   { "PARAM_FILENAME", var_filename },
 547   { "PARAM_ENUM", var_enum },
 548
 549   END_INTEGER_CONSTANTS
 550 };
 551
 552 /* Return non-zero if PARAM_TYPE is a valid parameter type.  */
 553
 554 static int
 555 pascm_valid_parameter_type_p (int param_type)
 556 {
 557   int i;
 558
 559   for (i = 0; parameter_types[i].name != NULL; ++i)
 560     {
 561       if (parameter_types[i].value == param_type)
 562         return 1;
 563     }
 564
 565   return 0;
 566 }
 567
 568 /* Return PARAM_TYPE as a string.  */
 569
 570 static const char *
 571 pascm_param_type_name (enum var_types param_type)
 572 {
 573   int i;
 574
 575   for (i = 0; parameter_types[i].name != NULL; ++i)
 576     {
 577       if (parameter_types[i].value == param_type)
 578         return parameter_types[i].name;
 579     }
 580
 581   gdb_assert_not_reached ("bad parameter type");
 582 }
 583
 584 /* Return the value of a gdb parameter as a Scheme value.
 585    If the var_type of VAR is not supported, then a <gdb:exception> object is
 586    returned.  */
 587
 588 static SCM
 589 pascm_param_value (const setting &var, int arg_pos, const char *func_name)
 590 {
 591   /* Note: We *could* support var_integer here in case someone is trying to get
 592      the value of a Python-created parameter (which is the only place that
 593      still supports var_integer).  To further discourage its use we do not.  */
 594
 595   switch (var.type ())
 596     {
 597     case var_string:
 598     case var_string_noescape:
 599     case var_optional_filename:
 600     case var_filename:
 601       {
 602         const std::string &str = var.get<std::string> ();
 603         return gdbscm_scm_from_host_string (str.c_str (), str.length ());
 604       }
 605
 606     case var_enum:
 607       {
 608         const char *str = var.get<const char *> ();
 609         if (str == nullptr)
 610           str = "";
 611         return gdbscm_scm_from_host_string (str, strlen (str));
 612       }
 613
 614     case var_boolean:
 615       {
 616         if (var.get<bool> ())
 617           return SCM_BOOL_T;
 618         else
 619           return SCM_BOOL_F;
 620       }
 621
 622     case var_auto_boolean:
 623       {
 624         enum auto_boolean ab = var.get<enum auto_boolean> ();
 625
 626         if (ab == AUTO_BOOLEAN_TRUE)
 627           return SCM_BOOL_T;
 628         else if (ab == AUTO_BOOLEAN_FALSE)
 629           return SCM_BOOL_F;
 630         else
 631           return auto_keyword;
 632       }
 633
 634     case var_zuinteger_unlimited:
 635       if (var.get<int> () == -1)
 636         return unlimited_keyword;
 637       gdb_assert (var.get<int> () >= 0);
 638       /* Fall through.  */
 639     case var_zinteger:
 640       return scm_from_int (var.get<int> ());
 641
 642     case var_uinteger:
 643       if (var.get<unsigned int> ()== UINT_MAX)
 644         return unlimited_keyword;
 645       /* Fall through.  */
 646     case var_zuinteger:
 647       return scm_from_uint (var.get<unsigned int> ());
 648
 649     default:
 650       break;
 651     }
 652
 653   return gdbscm_make_out_of_range_error (func_name, arg_pos,
 654                                          scm_from_int (var.type ()),
 655                                          _("program error: unhandled type"));
 656 }
 657
 658 /* Set the value of a parameter of type P_SMOB->TYPE in P_SMOB->VAR from VALUE.
 659    ENUMERATION is the list of enum values for enum parameters, otherwise NULL.
 660    Throws a Scheme exception if VALUE_SCM is invalid for TYPE.  */
 661
 662 static void
 663 pascm_set_param_value_x (param_smob *p_smob,
 664                          const char * const *enumeration,
 665                          SCM value, int arg_pos, const char *func_name)
 666 {
 667   setting var = make_setting (p_smob);
 668
 669   switch (var.type ())
 670     {
 671     case var_string:
 672     case var_string_noescape:
 673     case var_optional_filename:
 674     case var_filename:
 675       SCM_ASSERT_TYPE (scm_is_string (value)
 676                        || (var.type () != var_filename
 677                            && gdbscm_is_false (value)),
 678                        value, arg_pos, func_name,
 679                        _("string or #f for non-PARAM_FILENAME parameters"));
 680       if (gdbscm_is_false (value))
 681         var.set<std::string> ("");
 682       else
 683         {
 684           SCM exception;
 685
 686           gdb::unique_xmalloc_ptr<char> string
 687             = gdbscm_scm_to_host_string (value, nullptr, &exception);
 688           if (string == nullptr)
 689             gdbscm_throw (exception);
 690           var.set<std::string> (string.release ());
 691         }
 692       break;
 693
 694     case var_enum:
 695       {
 696         int i;
 697         SCM exception;
 698
 699         SCM_ASSERT_TYPE (scm_is_string (value), value, arg_pos, func_name,
 700                        _("string"));
 701         gdb::unique_xmalloc_ptr<char> str
 702           = gdbscm_scm_to_host_string (value, nullptr, &exception);
 703         if (str == nullptr)
 704           gdbscm_throw (exception);
 705         for (i = 0; enumeration[i]; ++i)
 706           {
 707             if (strcmp (enumeration[i], str.get ()) == 0)
 708               break;
 709           }
 710         if (enumeration[i] == nullptr)
 711           {
 712             gdbscm_out_of_range_error (func_name, arg_pos, value,
 713                                        _("not member of enumeration"));
 714           }
 715         var.set<const char *> (enumeration[i]);
 716         break;
 717       }
 718
 719     case var_boolean:
 720       SCM_ASSERT_TYPE (gdbscm_is_bool (value), value, arg_pos, func_name,
 721                        _("boolean"));
 722       var.set<bool> (gdbscm_is_true (value));
 723       break;
 724
 725     case var_auto_boolean:
 726       SCM_ASSERT_TYPE (gdbscm_is_bool (value)
 727                        || scm_is_eq (value, auto_keyword),
 728                        value, arg_pos, func_name,
 729                        _("boolean or #:auto"));
 730       if (scm_is_eq (value, auto_keyword))
 731         var.set<enum auto_boolean> (AUTO_BOOLEAN_AUTO);
 732       else if (gdbscm_is_true (value))
 733         var.set<enum auto_boolean> (AUTO_BOOLEAN_TRUE);
 734       else
 735         var.set<enum auto_boolean> (AUTO_BOOLEAN_FALSE);
 736       break;
 737
 738     case var_zinteger:
 739     case var_uinteger:
 740     case var_zuinteger:
 741     case var_zuinteger_unlimited:
 742       if (var.type () == var_uinteger
 743           || var.type () == var_zuinteger_unlimited)
 744         {
 745           SCM_ASSERT_TYPE (gdbscm_is_bool (value)
 746                            || scm_is_eq (value, unlimited_keyword),
 747                            value, arg_pos, func_name,
 748                            _("integer or #:unlimited"));
 749           if (scm_is_eq (value, unlimited_keyword))
 750             {
 751               if (var.type () == var_uinteger)
 752                 var.set<unsigned int> (UINT_MAX);
 753               else
 754                 var.set<int> (-1);
 755               break;
 756             }
 757         }
 758       else
 759         {
 760           SCM_ASSERT_TYPE (scm_is_integer (value), value, arg_pos, func_name,
 761                            _("integer"));
 762         }
 763
 764       if (var.type () == var_uinteger
 765           || var.type () == var_zuinteger)
 766         {
 767           unsigned int u = scm_to_uint (value);
 768
 769           if (var.type () == var_uinteger && u == 0)
 770             u = UINT_MAX;
 771           var.set<unsigned int> (u);
 772         }
 773       else
 774         {
 775           int i = scm_to_int (value);
 776
 777           if (var.type () == var_zuinteger_unlimited && i < -1)
 778             {
 779               gdbscm_out_of_range_error (func_name, arg_pos, value,
 780                                          _("must be >= -1"));
 781             }
 782           var.set<int> (i);
 783         }
 784       break;
 785
 786     default:
 787       gdb_assert_not_reached ("bad parameter type");
 788     }
 789 }
 790
 791 /* Free function for a param_smob.  */
 792 static size_t
 793 pascm_free_parameter_smob (SCM self)
 794 {
 795   param_smob *p_smob = (param_smob *) SCM_SMOB_DATA (self);
 796
 797   if (var_type_uses<std::string> (p_smob->type))
 798     {
 799       delete p_smob->value.stringval;
 800       p_smob->value.stringval = nullptr;
 801     }
 802
 803   return 0;
 804 }
 805 \f
 806 /* Parameter Scheme functions.  */
 807
 808 /* (make-parameter name
 809      [#:command-class cmd-class] [#:parameter-type param-type]
 810      [#:enum-list enum-list] [#:set-func function] [#:show-func function]
 811      [#:doc <string>] [#:set-doc <string>] [#:show-doc <string>]
 812      [#:initial-value initial-value]) -> <gdb:parameter>
 813
 814    NAME is the name of the parameter.  It may consist of multiple
 815    words, in which case the final word is the name of the new parameter,
 816    and earlier words must be prefix commands.
 817
 818    CMD-CLASS is the kind of command.  It should be one of the COMMAND_*
 819    constants defined in the gdb module.
 820
 821    PARAM_TYPE is the type of the parameter.  It should be one of the
 822    PARAM_* constants defined in the gdb module.
 823
 824    If PARAM-TYPE is PARAM_ENUM, then ENUM-LIST is a list of strings that
 825    are the valid values for this parameter.  The first value is the default.
 826
 827    SET-FUNC, if provided, is called after the parameter is set.
 828    It is a function of one parameter: the <gdb:parameter> object.
 829    It must return a string to be displayed to the user.
 830    Setting a parameter is typically a silent operation, so typically ""
 831    should be returned.
 832
 833    SHOW-FUNC, if provided, returns the string that is printed.
 834    It is a function of two parameters: the <gdb:parameter> object
 835    and the current value of the parameter as a string.
 836
 837    DOC, SET-DOC, SHOW-DOC are the doc strings for the parameter.
 838
 839    INITIAL-VALUE is the initial value of the parameter.
 840
 841    The result is the <gdb:parameter> Scheme object.
 842    The parameter is not available to be used yet, however.
 843    It must still be added to gdb with register-parameter!.  */
 844
 845 static SCM
 846 gdbscm_make_parameter (SCM name_scm, SCM rest)
 847 {
 848   const SCM keywords[] = {
 849     command_class_keyword, parameter_type_keyword, enum_list_keyword,
 850     set_func_keyword, show_func_keyword,
 851     doc_keyword, set_doc_keyword, show_doc_keyword,
 852     initial_value_keyword, SCM_BOOL_F
 853   };
 854   int cmd_class_arg_pos = -1, param_type_arg_pos = -1;
 855   int enum_list_arg_pos = -1, set_func_arg_pos = -1, show_func_arg_pos = -1;
 856   int doc_arg_pos = -1, set_doc_arg_pos = -1, show_doc_arg_pos = -1;
 857   int initial_value_arg_pos = -1;
 858   char *s;
 859   char *name;
 860   int cmd_class = no_class;
 861   int param_type = var_boolean; /* ARI: var_boolean */
 862   SCM enum_list_scm = SCM_BOOL_F;
 863   SCM set_func = SCM_BOOL_F, show_func = SCM_BOOL_F;
 864   char *doc = NULL, *set_doc = NULL, *show_doc = NULL;
 865   SCM initial_value_scm = SCM_BOOL_F;
 866   const char * const *enum_list = NULL;
 867   SCM p_scm;
 868   param_smob *p_smob;
 869
 870   gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, keywords, "s#iiOOOsssO",
 871                               name_scm, &name, rest,
 872                               &cmd_class_arg_pos, &cmd_class,
 873                               &param_type_arg_pos, &param_type,
 874                               &enum_list_arg_pos, &enum_list_scm,
 875                               &set_func_arg_pos, &set_func,
 876                               &show_func_arg_pos, &show_func,
 877                               &doc_arg_pos, &doc,
 878                               &set_doc_arg_pos, &set_doc,
 879                               &show_doc_arg_pos, &show_doc,
 880                               &initial_value_arg_pos, &initial_value_scm);
 881
 882   /* If doc is NULL, leave it NULL.  See add_setshow_cmd_full.  */
 883   if (set_doc == NULL)
 884     set_doc = get_doc_string ();
 885   if (show_doc == NULL)
 886     show_doc = get_doc_string ();
 887
 888   s = name;
 889   name = gdbscm_canonicalize_command_name (s, 0);
 890   xfree (s);
 891   if (doc != NULL)
 892     {
 893       s = doc;
 894       doc = gdbscm_gc_xstrdup (s);
 895       xfree (s);
 896     }
 897   s = set_doc;
 898   set_doc = gdbscm_gc_xstrdup (s);
 899   xfree (s);
 900   s = show_doc;
 901   show_doc = gdbscm_gc_xstrdup (s);
 902   xfree (s);
 903
 904   if (!gdbscm_valid_command_class_p (cmd_class))
 905     {
 906       gdbscm_out_of_range_error (FUNC_NAME, cmd_class_arg_pos,
 907                                  scm_from_int (cmd_class),
 908                                  _("invalid command class argument"));
 909     }
 910   if (!pascm_valid_parameter_type_p (param_type))
 911     {
 912       gdbscm_out_of_range_error (FUNC_NAME, param_type_arg_pos,
 913                                  scm_from_int (param_type),
 914                                  _("invalid parameter type argument"));
 915     }
 916   if (enum_list_arg_pos > 0 && param_type != var_enum)
 917     {
 918       gdbscm_misc_error (FUNC_NAME, enum_list_arg_pos, enum_list_scm,
 919                 _("#:enum-values can only be provided with PARAM_ENUM"));
 920     }
 921   if (enum_list_arg_pos < 0 && param_type == var_enum)
 922     {
 923       gdbscm_misc_error (FUNC_NAME, GDBSCM_ARG_NONE, SCM_BOOL_F,
 924                          _("PARAM_ENUM requires an enum-values argument"));
 925     }
 926   if (set_func_arg_pos > 0)
 927     {
 928       SCM_ASSERT_TYPE (gdbscm_is_procedure (set_func), set_func,
 929                        set_func_arg_pos, FUNC_NAME, _("procedure"));
 930     }
 931   if (show_func_arg_pos > 0)
 932     {
 933       SCM_ASSERT_TYPE (gdbscm_is_procedure (show_func), show_func,
 934                        show_func_arg_pos, FUNC_NAME, _("procedure"));
 935     }
 936   if (param_type == var_enum)
 937     {
 938       /* Note: enum_list lives in GC space, so we don't have to worry about
 939          freeing it if we later throw an exception.  */
 940       enum_list = compute_enum_list (enum_list_scm, enum_list_arg_pos,
 941                                      FUNC_NAME);
 942     }
 943
 944   /* If initial-value is a function, we need the parameter object constructed
 945      to pass it to the function.  A typical thing the function may want to do
 946      is add an object-property to it to record the last known good value.  */
 947   p_scm = pascm_make_param_smob ();
 948   p_smob = (param_smob *) SCM_SMOB_DATA (p_scm);
 949   /* These are all stored in GC space so that we don't have to worry about
 950      freeing them if we throw an exception.  */
 951   p_smob->name = name;
 952   p_smob->cmd_class = (enum command_class) cmd_class;
 953   p_smob->type = (enum var_types) param_type;
 954   p_smob->doc = doc;
 955   p_smob->set_doc = set_doc;
 956   p_smob->show_doc = show_doc;
 957   p_smob->enumeration = enum_list;
 958   p_smob->set_func = set_func;
 959   p_smob->show_func = show_func;
 960
 961   scm_set_smob_free (parameter_smob_tag, pascm_free_parameter_smob);
 962   if (var_type_uses<std::string> (p_smob->type))
 963     p_smob->value.stringval = new std::string;
 964
 965   if (initial_value_arg_pos > 0)
 966     {
 967       if (gdbscm_is_procedure (initial_value_scm))
 968         {
 969           initial_value_scm = gdbscm_safe_call_1 (initial_value_scm,
 970                                                   p_smob->containing_scm, NULL);
 971           if (gdbscm_is_exception (initial_value_scm))
 972             gdbscm_throw (initial_value_scm);
 973         }
 974       pascm_set_param_value_x (p_smob, enum_list,
 975                                initial_value_scm,
 976                                initial_value_arg_pos, FUNC_NAME);
 977     }
 978
 979   return p_scm;
 980 }
 981
 982 /* Subroutine of gdbscm_register_parameter_x to simplify it.
 983    Return non-zero if parameter NAME is already defined in LIST.  */
 984
 985 static int
 986 pascm_parameter_defined_p (const char *name, struct cmd_list_element *list)
 987 {
 988   struct cmd_list_element *c;
 989
 990   c = lookup_cmd_1 (&name, list, NULL, NULL, 1);
 991
 992   /* If the name is ambiguous that's ok, it's a new parameter still.  */
 993   return c != NULL && c != CMD_LIST_AMBIGUOUS;
 994 }
 995
 996 /* (register-parameter! <gdb:parameter>) -> unspecified
 997
 998    It is an error to register a pre-existing parameter.  */
 999
1000 static SCM
1001 gdbscm_register_parameter_x (SCM self)
1002 {
1003   param_smob *p_smob
1004     = pascm_get_param_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1005   char *cmd_name;
1006   struct cmd_list_element **set_list, **show_list;
1007
1008   if (pascm_is_valid (p_smob))
1009     scm_misc_error (FUNC_NAME, _("parameter is already registered"), SCM_EOL);
1010
1011   cmd_name = gdbscm_parse_command_name (p_smob->name, FUNC_NAME, SCM_ARG1,
1012                                         &set_list, &setlist);
1013   xfree (cmd_name);
1014   cmd_name = gdbscm_parse_command_name (p_smob->name, FUNC_NAME, SCM_ARG1,
1015                                         &show_list, &showlist);
1016   p_smob->cmd_name = gdbscm_gc_xstrdup (cmd_name);
1017   xfree (cmd_name);
1018
1019   if (pascm_parameter_defined_p (p_smob->cmd_name, *set_list))
1020     {
1021       gdbscm_misc_error (FUNC_NAME, SCM_ARG1, self,
1022                 _("parameter exists, \"set\" command is already defined"));
1023     }
1024   if (pascm_parameter_defined_p (p_smob->cmd_name, *show_list))
1025     {
1026       gdbscm_misc_error (FUNC_NAME, SCM_ARG1, self,
1027                 _("parameter exists, \"show\" command is already defined"));
1028     }
1029
1030   gdbscm_gdb_exception exc {};
1031   try
1032     {
1033       p_smob->commands = add_setshow_generic
1034         (p_smob->type, p_smob->cmd_class, p_smob->cmd_name, p_smob,
1035          p_smob->set_doc, p_smob->show_doc, p_smob->doc,
1036          (gdbscm_is_procedure (p_smob->set_func) ? pascm_set_func : NULL),
1037          (gdbscm_is_procedure (p_smob->show_func) ? pascm_show_func : NULL),
1038          set_list, show_list);
1039     }
1040   catch (const gdb_exception &except)
1041     {
1042       exc = unpack (except);
1043     }
1044
1045   GDBSCM_HANDLE_GDB_EXCEPTION (exc);
1046   /* Note: At this point the parameter exists in gdb.
1047      So no more errors after this point.  */
1048
1049   /* The owner of this parameter is not in GC-controlled memory, so we need
1050      to protect it from GC until the parameter is deleted.  */
1051   scm_gc_protect_object (p_smob->containing_scm);
1052
1053   return SCM_UNSPECIFIED;
1054 }
1055
1056 /* (parameter-value <gdb:parameter>) -> value
1057    (parameter-value <string>) -> value */
1058
1059 static SCM
1060 gdbscm_parameter_value (SCM self)
1061 {
1062   SCM_ASSERT_TYPE (pascm_is_parameter (self) || scm_is_string (self),
1063                    self, SCM_ARG1, FUNC_NAME, _("<gdb:parameter> or string"));
1064
1065   if (pascm_is_parameter (self))
1066     {
1067       param_smob *p_smob = pascm_get_param_smob_arg_unsafe (self, SCM_ARG1,
1068                                                             FUNC_NAME);
1069
1070       return pascm_param_value (make_setting (p_smob), SCM_ARG1, FUNC_NAME);
1071     }
1072   else
1073     {
1074       SCM except_scm;
1075       struct cmd_list_element *alias, *prefix, *cmd;
1076       char *newarg;
1077       int found = -1;
1078       gdbscm_gdb_exception except {};
1079
1080       gdb::unique_xmalloc_ptr<char> name
1081         = gdbscm_scm_to_host_string (self, NULL, &except_scm);
1082       if (name == NULL)
1083         gdbscm_throw (except_scm);
1084       newarg = concat ("show ", name.get (), (char *) NULL);
1085       try
1086         {
1087           found = lookup_cmd_composition (newarg, &alias, &prefix, &cmd);
1088         }
1089       catch (const gdb_exception &ex)
1090         {
1091           except = unpack (ex);
1092         }
1093
1094       xfree (newarg);
1095       GDBSCM_HANDLE_GDB_EXCEPTION (except);
1096       if (!found)
1097         {
1098           gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, self,
1099                                      _("parameter not found"));
1100         }
1101
1102       if (!cmd->var.has_value ())
1103         {
1104           gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, self,
1105                                      _("not a parameter"));
1106         }
1107
1108       return pascm_param_value (*cmd->var, SCM_ARG1, FUNC_NAME);
1109     }
1110 }
1111
1112 /* (set-parameter-value! <gdb:parameter> value) -> unspecified */
1113
1114 static SCM
1115 gdbscm_set_parameter_value_x (SCM self, SCM value)
1116 {
1117   param_smob *p_smob = pascm_get_param_smob_arg_unsafe (self, SCM_ARG1,
1118                                                         FUNC_NAME);
1119
1120   pascm_set_param_value_x (p_smob, p_smob->enumeration,
1121                            value, SCM_ARG2, FUNC_NAME);
1122
1123   return SCM_UNSPECIFIED;
1124 }
1125 \f
1126 /* Initialize the Scheme parameter support.  */
1127
1128 static const scheme_function parameter_functions[] =
1129 {
1130   { "make-parameter", 1, 0, 1, as_a_scm_t_subr (gdbscm_make_parameter),
1131     "\
1132 Make a GDB parameter object.\n\
1133 \n\
1134   Arguments: name\n\
1135       [#:command-class <cmd-class>] [#:parameter-type <parameter-type>]\n\
1136       [#:enum-list <enum-list>]\n\
1137       [#:set-func function] [#:show-func function]\n\
1138       [#:doc string] [#:set-doc string] [#:show-doc string]\n\
1139       [#:initial-value initial-value]\n\
1140     name: The name of the command.  It may consist of multiple words,\n\
1141       in which case the final word is the name of the new parameter, and\n\
1142       earlier words must be prefix commands.\n\
1143     cmd-class: The class of the command, one of COMMAND_*.\n\
1144       The default is COMMAND_NONE.\n\
1145     parameter-type: The kind of parameter, one of PARAM_*\n\
1146       The default is PARAM_BOOLEAN.\n\
1147     enum-list: If parameter-type is PARAM_ENUM, then this specifies the set\n\
1148       of values of the enum.\n\
1149     set-func: A function of one parameter: the <gdb:parameter> object.\n\
1150       Called *after* the parameter has been set.  Returns either \"\" or a\n\
1151       non-empty string to be displayed to the user.\n\
1152       If non-empty, GDB will add a trailing newline.\n\
1153     show-func: A function of two parameters: the <gdb:parameter> object\n\
1154       and the string representation of the current value.\n\
1155       The result is a string to be displayed to the user.\n\
1156       GDB will add a trailing newline.\n\
1157     doc: The \"doc string\" of the parameter.\n\
1158     set-doc: The \"doc string\" when setting the parameter.\n\
1159     show-doc: The \"doc string\" when showing the parameter.\n\
1160     initial-value: The initial value of the parameter." },
1161
1162   { "register-parameter!", 1, 0, 0,
1163     as_a_scm_t_subr (gdbscm_register_parameter_x),
1164     "\
1165 Register a <gdb:parameter> object with GDB." },
1166
1167   { "parameter?", 1, 0, 0, as_a_scm_t_subr (gdbscm_parameter_p),
1168     "\
1169 Return #t if the object is a <gdb:parameter> object." },
1170
1171   { "parameter-value", 1, 0, 0, as_a_scm_t_subr (gdbscm_parameter_value),
1172     "\
1173 Return the value of a <gdb:parameter> object\n\
1174 or any gdb parameter if param is a string naming the parameter." },
1175
1176   { "set-parameter-value!", 2, 0, 0,
1177     as_a_scm_t_subr (gdbscm_set_parameter_value_x),
1178     "\
1179 Set the value of a <gdb:parameter> object.\n\
1180 \n\
1181   Arguments: <gdb:parameter> value" },
1182
1183   END_FUNCTIONS
1184 };
1185
1186 void
1187 gdbscm_initialize_parameters (void)
1188 {
1189   parameter_smob_tag
1190     = gdbscm_make_smob_type (param_smob_name, sizeof (param_smob));
1191   scm_set_smob_print (parameter_smob_tag, pascm_print_param_smob);
1192
1193   gdbscm_define_integer_constants (parameter_types, 1);
1194   gdbscm_define_functions (parameter_functions, 1);
1195
1196   command_class_keyword = scm_from_latin1_keyword ("command-class");
1197   parameter_type_keyword = scm_from_latin1_keyword ("parameter-type");
1198   enum_list_keyword = scm_from_latin1_keyword ("enum-list");
1199   set_func_keyword = scm_from_latin1_keyword ("set-func");
1200   show_func_keyword = scm_from_latin1_keyword ("show-func");
1201   doc_keyword = scm_from_latin1_keyword ("doc");
1202   set_doc_keyword = scm_from_latin1_keyword ("set-doc");
1203   show_doc_keyword = scm_from_latin1_keyword ("show-doc");
1204   initial_value_keyword = scm_from_latin1_keyword ("initial-value");
1205   auto_keyword = scm_from_latin1_keyword ("auto");
1206   unlimited_keyword = scm_from_latin1_keyword ("unlimited");
1207 }