gdb/guile/scm-param.c

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