gdb/guile/scm-param.c

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