gdb/guile/scm-param.c

   1 /* GDB parameters implemented in Guile.
   2
   3    Copyright (C) 2008-2015 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 = xmalloc ((size + 1) * sizeof (char *));
 507   memset (enum_values, 0, (size + 1) * sizeof (char *));
 508
 509   i = 0;
 510   while (!scm_is_eq (enum_values_scm, SCM_EOL))
 511     {
 512       SCM value = scm_car (enum_values_scm);
 513       SCM exception;
 514
 515       if (!scm_is_string (value))
 516         {
 517           freeargv (enum_values);
 518           SCM_ASSERT_TYPE (0, value, arg_pos, func_name, _("string"));
 519         }
 520       enum_values[i] = gdbscm_scm_to_host_string (value, NULL, &exception);
 521       if (enum_values[i] == NULL)
 522         {
 523           freeargv (enum_values);
 524           gdbscm_throw (exception);
 525         }
 526       ++i;
 527       enum_values_scm = scm_cdr (enum_values_scm);
 528     }
 529   gdb_assert (i == size);
 530
 531   result = gdbscm_gc_dup_argv (enum_values);
 532   freeargv (enum_values);
 533   return result;
 534 }
 535
 536 static const scheme_integer_constant parameter_types[] =
 537 {
 538   /* Note: var_integer is deprecated, and intentionally does not
 539      appear here.  */
 540   { "PARAM_BOOLEAN", var_boolean }, /* ARI: var_boolean */
 541   { "PARAM_AUTO_BOOLEAN", var_auto_boolean },
 542   { "PARAM_ZINTEGER", var_zinteger },
 543   { "PARAM_UINTEGER", var_uinteger },
 544   { "PARAM_ZUINTEGER", var_zuinteger },
 545   { "PARAM_ZUINTEGER_UNLIMITED", var_zuinteger_unlimited },
 546   { "PARAM_STRING", var_string },
 547   { "PARAM_STRING_NOESCAPE", var_string_noescape },
 548   { "PARAM_OPTIONAL_FILENAME", var_optional_filename },
 549   { "PARAM_FILENAME", var_filename },
 550   { "PARAM_ENUM", var_enum },
 551
 552   END_INTEGER_CONSTANTS
 553 };
 554
 555 /* Return non-zero if PARAM_TYPE is a valid parameter type.  */
 556
 557 static int
 558 pascm_valid_parameter_type_p (int param_type)
 559 {
 560   int i;
 561
 562   for (i = 0; parameter_types[i].name != NULL; ++i)
 563     {
 564       if (parameter_types[i].value == param_type)
 565         return 1;
 566     }
 567
 568   return 0;
 569 }
 570
 571 /* Return PARAM_TYPE as a string.  */
 572
 573 static const char *
 574 pascm_param_type_name (enum var_types param_type)
 575 {
 576   int i;
 577
 578   for (i = 0; parameter_types[i].name != NULL; ++i)
 579     {
 580       if (parameter_types[i].value == param_type)
 581         return parameter_types[i].name;
 582     }
 583
 584   gdb_assert_not_reached ("bad parameter type");
 585 }
 586
 587 /* Return the value of a gdb parameter as a Scheme value.
 588    If TYPE is not supported, then a <gdb:exception> object is returned.  */
 589
 590 static SCM
 591 pascm_param_value (enum var_types type, void *var,
 592                    int arg_pos, const char *func_name)
 593 {
 594   /* Note: We *could* support var_integer here in case someone is trying to get
 595      the value of a Python-created parameter (which is the only place that
 596      still supports var_integer).  To further discourage its use we do not.  */
 597
 598   switch (type)
 599     {
 600     case var_string:
 601     case var_string_noescape:
 602     case var_optional_filename:
 603     case var_filename:
 604     case var_enum:
 605       {
 606         char *str = * (char **) var;
 607
 608         if (str == NULL)
 609           str = "";
 610         return gdbscm_scm_from_host_string (str, strlen (str));
 611       }
 612
 613     case var_boolean:
 614       {
 615         if (* (int *) var)
 616           return SCM_BOOL_T;
 617         else
 618           return SCM_BOOL_F;
 619       }
 620
 621     case var_auto_boolean:
 622       {
 623         enum auto_boolean ab = * (enum auto_boolean *) var;
 624
 625         if (ab == AUTO_BOOLEAN_TRUE)
 626           return SCM_BOOL_T;
 627         else if (ab == AUTO_BOOLEAN_FALSE)
 628           return SCM_BOOL_F;
 629         else
 630           return auto_keyword;
 631       }
 632
 633     case var_zuinteger_unlimited:
 634       if (* (int *) var == -1)
 635         return unlimited_keyword;
 636       gdb_assert (* (int *) var >= 0);
 637       /* Fall through.  */
 638     case var_zinteger:
 639       return scm_from_int (* (int *) var);
 640
 641     case var_uinteger:
 642       if (* (unsigned int *) var == UINT_MAX)
 643         return unlimited_keyword;
 644       /* Fall through.  */
 645     case var_zuinteger:
 646       return scm_from_uint (* (unsigned int *) var);
 647
 648     default:
 649       break;
 650     }
 651
 652   return gdbscm_make_out_of_range_error (func_name, arg_pos,
 653                                          scm_from_int (type),
 654                                          _("program error: unhandled type"));
 655 }
 656
 657 /* Set the value of a parameter of type TYPE in VAR from VALUE.
 658    ENUMERATION is the list of enum values for enum parameters, otherwise NULL.
 659    Throws a Scheme exception if VALUE_SCM is invalid for TYPE.  */
 660
 661 static void
 662 pascm_set_param_value_x (enum var_types type, union pascm_variable *var,
 663                          const char * const *enumeration,
 664                          SCM value, int arg_pos, const char *func_name)
 665 {
 666   switch (type)
 667     {
 668     case var_string:
 669     case var_string_noescape:
 670     case var_optional_filename:
 671     case var_filename:
 672       SCM_ASSERT_TYPE (scm_is_string (value)
 673                        || (type != var_filename
 674                            && gdbscm_is_false (value)),
 675                        value, arg_pos, func_name,
 676                        _("string or #f for non-PARAM_FILENAME parameters"));
 677       if (gdbscm_is_false (value))
 678         {
 679           xfree (var->stringval);
 680           if (type == var_optional_filename)
 681             var->stringval = xstrdup ("");
 682           else
 683             var->stringval = NULL;
 684         }
 685       else
 686         {
 687           char *string;
 688           SCM exception;
 689
 690           string = gdbscm_scm_to_host_string (value, NULL, &exception);
 691           if (string == NULL)
 692             gdbscm_throw (exception);
 693           xfree (var->stringval);
 694           var->stringval = string;
 695         }
 696       break;
 697
 698     case var_enum:
 699       {
 700         int i;
 701         char *str;
 702         SCM exception;
 703
 704         SCM_ASSERT_TYPE (scm_is_string (value), value, arg_pos, func_name,
 705                        _("string"));
 706         str = gdbscm_scm_to_host_string (value, NULL, &exception);
 707         if (str == NULL)
 708           gdbscm_throw (exception);
 709         for (i = 0; enumeration[i]; ++i)
 710           {
 711             if (strcmp (enumeration[i], str) == 0)
 712               break;
 713           }
 714         xfree (str);
 715         if (enumeration[i] == NULL)
 716           {
 717             gdbscm_out_of_range_error (func_name, arg_pos, value,
 718                                        _("not member of enumeration"));
 719           }
 720         var->cstringval = enumeration[i];
 721         break;
 722       }
 723
 724     case var_boolean:
 725       SCM_ASSERT_TYPE (gdbscm_is_bool (value), value, arg_pos, func_name,
 726                        _("boolean"));
 727       var->intval = gdbscm_is_true (value);
 728       break;
 729
 730     case var_auto_boolean:
 731       SCM_ASSERT_TYPE (gdbscm_is_bool (value)
 732                        || scm_is_eq (value, auto_keyword),
 733                        value, arg_pos, func_name,
 734                        _("boolean or #:auto"));
 735       if (scm_is_eq (value, auto_keyword))
 736         var->autoboolval = AUTO_BOOLEAN_AUTO;
 737       else if (gdbscm_is_true (value))
 738         var->autoboolval = AUTO_BOOLEAN_TRUE;
 739       else
 740         var->autoboolval = AUTO_BOOLEAN_FALSE;
 741       break;
 742
 743     case var_zinteger:
 744     case var_uinteger:
 745     case var_zuinteger:
 746     case var_zuinteger_unlimited:
 747       if (type == var_uinteger
 748           || type == var_zuinteger_unlimited)
 749         {
 750           SCM_ASSERT_TYPE (gdbscm_is_bool (value)
 751                            || scm_is_eq (value, unlimited_keyword),
 752                            value, arg_pos, func_name,
 753                            _("integer or #:unlimited"));
 754           if (scm_is_eq (value, unlimited_keyword))
 755             {
 756               if (type == var_uinteger)
 757                 var->intval = UINT_MAX;
 758               else
 759                 var->intval = -1;
 760               break;
 761             }
 762         }
 763       else
 764         {
 765           SCM_ASSERT_TYPE (scm_is_integer (value), value, arg_pos, func_name,
 766                            _("integer"));
 767         }
 768
 769       if (type == var_uinteger
 770           || type == var_zuinteger)
 771         {
 772           unsigned int u = scm_to_uint (value);
 773
 774           if (type == var_uinteger && u == 0)
 775             u = UINT_MAX;
 776           var->uintval = u;
 777         }
 778       else
 779         {
 780           int i = scm_to_int (value);
 781
 782           if (type == var_zuinteger_unlimited && i < -1)
 783             {
 784               gdbscm_out_of_range_error (func_name, arg_pos, value,
 785                                          _("must be >= -1"));
 786             }
 787           var->intval = i;
 788         }
 789       break;
 790
 791     default:
 792       gdb_assert_not_reached ("bad parameter type");
 793     }
 794 }
 795 \f
 796 /* Parameter Scheme functions.  */
 797
 798 /* (make-parameter name
 799      [#:command-class cmd-class] [#:parameter-type param-type]
 800      [#:enum-list enum-list] [#:set-func function] [#:show-func function]
 801      [#:doc <string>] [#:set-doc <string>] [#:show-doc <string>]
 802      [#:initial-value initial-value]) -> <gdb:parameter>
 803
 804    NAME is the name of the parameter.  It may consist of multiple
 805    words, in which case the final word is the name of the new parameter,
 806    and earlier words must be prefix commands.
 807
 808    CMD-CLASS is the kind of command.  It should be one of the COMMAND_*
 809    constants defined in the gdb module.
 810
 811    PARAM_TYPE is the type of the parameter.  It should be one of the
 812    PARAM_* constants defined in the gdb module.
 813
 814    If PARAM-TYPE is PARAM_ENUM, then ENUM-LIST is a list of strings that
 815    are the valid values for this parameter.  The first value is the default.
 816
 817    SET-FUNC, if provided, is called after the parameter is set.
 818    It is a function of one parameter: the <gdb:parameter> object.
 819    It must return a string to be displayed to the user.
 820    Setting a parameter is typically a silent operation, so typically ""
 821    should be returned.
 822
 823    SHOW-FUNC, if provided, returns the string that is printed.
 824    It is a function of two parameters: the <gdb:parameter> object
 825    and the current value of the parameter as a string.
 826
 827    DOC, SET-DOC, SHOW-DOC are the doc strings for the parameter.
 828
 829    INITIAL-VALUE is the initial value of the parameter.
 830
 831    The result is the <gdb:parameter> Scheme object.
 832    The parameter is not available to be used yet, however.
 833    It must still be added to gdb with register-parameter!.  */
 834
 835 static SCM
 836 gdbscm_make_parameter (SCM name_scm, SCM rest)
 837 {
 838   const SCM keywords[] = {
 839     command_class_keyword, parameter_type_keyword, enum_list_keyword,
 840     set_func_keyword, show_func_keyword,
 841     doc_keyword, set_doc_keyword, show_doc_keyword,
 842     initial_value_keyword, SCM_BOOL_F
 843   };
 844   int cmd_class_arg_pos = -1, param_type_arg_pos = -1;
 845   int enum_list_arg_pos = -1, set_func_arg_pos = -1, show_func_arg_pos = -1;
 846   int doc_arg_pos = -1, set_doc_arg_pos = -1, show_doc_arg_pos = -1;
 847   int initial_value_arg_pos = -1;
 848   char *s;
 849   char *name;
 850   int cmd_class = no_class;
 851   int param_type = var_boolean; /* ARI: var_boolean */
 852   SCM enum_list_scm = SCM_BOOL_F;
 853   SCM set_func = SCM_BOOL_F, show_func = SCM_BOOL_F;
 854   char *doc = NULL, *set_doc = NULL, *show_doc = NULL;
 855   SCM initial_value_scm = SCM_BOOL_F;
 856   const char * const *enum_list = NULL;
 857   SCM p_scm;
 858   param_smob *p_smob;
 859
 860   gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, keywords, "s#iiOOOsssO",
 861                               name_scm, &name, rest,
 862                               &cmd_class_arg_pos, &cmd_class,
 863                               &param_type_arg_pos, &param_type,
 864                               &enum_list_arg_pos, &enum_list_scm,
 865                               &set_func_arg_pos, &set_func,
 866                               &show_func_arg_pos, &show_func,
 867                               &doc_arg_pos, &doc,
 868                               &set_doc_arg_pos, &set_doc,
 869                               &show_doc_arg_pos, &show_doc,
 870                               &initial_value_arg_pos, &initial_value_scm);
 871
 872   /* If doc is NULL, leave it NULL.  See add_setshow_cmd_full.  */
 873   if (set_doc == NULL)
 874     set_doc = get_doc_string ();
 875   if (show_doc == NULL)
 876     show_doc = get_doc_string ();
 877
 878   s = name;
 879   name = gdbscm_canonicalize_command_name (s, 0);
 880   xfree (s);
 881   if (doc != NULL)
 882     {
 883       s = doc;
 884       doc = gdbscm_gc_xstrdup (s);
 885       xfree (s);
 886     }
 887   s = set_doc;
 888   set_doc = gdbscm_gc_xstrdup (s);
 889   xfree (s);
 890   s = show_doc;
 891   show_doc = gdbscm_gc_xstrdup (s);
 892   xfree (s);
 893
 894   if (!gdbscm_valid_command_class_p (cmd_class))
 895     {
 896       gdbscm_out_of_range_error (FUNC_NAME, cmd_class_arg_pos,
 897                                  scm_from_int (cmd_class),
 898                                  _("invalid command class argument"));
 899     }
 900   if (!pascm_valid_parameter_type_p (param_type))
 901     {
 902       gdbscm_out_of_range_error (FUNC_NAME, param_type_arg_pos,
 903                                  scm_from_int (param_type),
 904                                  _("invalid parameter type argument"));
 905     }
 906   if (enum_list_arg_pos > 0 && param_type != var_enum)
 907     {
 908       gdbscm_misc_error (FUNC_NAME, enum_list_arg_pos, enum_list_scm,
 909                 _("#:enum-values can only be provided with PARAM_ENUM"));
 910     }
 911   if (enum_list_arg_pos < 0 && param_type == var_enum)
 912     {
 913       gdbscm_misc_error (FUNC_NAME, GDBSCM_ARG_NONE, SCM_BOOL_F,
 914                          _("PARAM_ENUM requires an enum-values argument"));
 915     }
 916   if (set_func_arg_pos > 0)
 917     {
 918       SCM_ASSERT_TYPE (gdbscm_is_procedure (set_func), set_func,
 919                        set_func_arg_pos, FUNC_NAME, _("procedure"));
 920     }
 921   if (show_func_arg_pos > 0)
 922     {
 923       SCM_ASSERT_TYPE (gdbscm_is_procedure (show_func), show_func,
 924                        show_func_arg_pos, FUNC_NAME, _("procedure"));
 925     }
 926   if (param_type == var_enum)
 927     {
 928       /* Note: enum_list lives in GC space, so we don't have to worry about
 929          freeing it if we later throw an exception.  */
 930       enum_list = compute_enum_list (enum_list_scm, enum_list_arg_pos,
 931                                      FUNC_NAME);
 932     }
 933
 934   /* If initial-value is a function, we need the parameter object constructed
 935      to pass it to the function.  A typical thing the function may want to do
 936      is add an object-property to it to record the last known good value.  */
 937   p_scm = pascm_make_param_smob ();
 938   p_smob = (param_smob *) SCM_SMOB_DATA (p_scm);
 939   /* These are all stored in GC space so that we don't have to worry about
 940      freeing them if we throw an exception.  */
 941   p_smob->name = name;
 942   p_smob->cmd_class = cmd_class;
 943   p_smob->type = (enum var_types) param_type;
 944   p_smob->doc = doc;
 945   p_smob->set_doc = set_doc;
 946   p_smob->show_doc = show_doc;
 947   p_smob->enumeration = enum_list;
 948   p_smob->set_func = set_func;
 949   p_smob->show_func = show_func;
 950
 951   if (initial_value_arg_pos > 0)
 952     {
 953       if (gdbscm_is_procedure (initial_value_scm))
 954         {
 955           initial_value_scm = gdbscm_safe_call_1 (initial_value_scm,
 956                                                   p_smob->containing_scm, NULL);
 957           if (gdbscm_is_exception (initial_value_scm))
 958             gdbscm_throw (initial_value_scm);
 959         }
 960       pascm_set_param_value_x (param_type, &p_smob->value, enum_list,
 961                                initial_value_scm,
 962                                initial_value_arg_pos, FUNC_NAME);
 963     }
 964
 965   return p_scm;
 966 }
 967
 968 /* Subroutine of gdbscm_register_parameter_x to simplify it.
 969    Return non-zero if parameter NAME is already defined in LIST.  */
 970
 971 static int
 972 pascm_parameter_defined_p (const char *name, struct cmd_list_element *list)
 973 {
 974   struct cmd_list_element *c;
 975
 976   c = lookup_cmd_1 (&name, list, NULL, 1);
 977
 978   /* If the name is ambiguous that's ok, it's a new parameter still.  */
 979   return c != NULL && c != CMD_LIST_AMBIGUOUS;
 980 }
 981
 982 /* (register-parameter! <gdb:parameter>) -> unspecified
 983
 984    It is an error to register a pre-existing parameter.  */
 985
 986 static SCM
 987 gdbscm_register_parameter_x (SCM self)
 988 {
 989   param_smob *p_smob
 990     = pascm_get_param_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 991   char *cmd_name;
 992   struct cmd_list_element **set_list, **show_list;
 993   volatile struct gdb_exception except;
 994
 995   if (pascm_is_valid (p_smob))
 996     scm_misc_error (FUNC_NAME, _("parameter is already registered"), SCM_EOL);
 997
 998   cmd_name = gdbscm_parse_command_name (p_smob->name, FUNC_NAME, SCM_ARG1,
 999                                         &set_list, &setlist);
1000   xfree (cmd_name);
1001   cmd_name = gdbscm_parse_command_name (p_smob->name, FUNC_NAME, SCM_ARG1,
1002                                         &show_list, &showlist);
1003   p_smob->cmd_name = gdbscm_gc_xstrdup (cmd_name);
1004   xfree (cmd_name);
1005
1006   if (pascm_parameter_defined_p (p_smob->cmd_name, *set_list))
1007     {
1008       gdbscm_misc_error (FUNC_NAME, SCM_ARG1, self,
1009                 _("parameter exists, \"set\" command is already defined"));
1010     }
1011   if (pascm_parameter_defined_p (p_smob->cmd_name, *show_list))
1012     {
1013       gdbscm_misc_error (FUNC_NAME, SCM_ARG1, self,
1014                 _("parameter exists, \"show\" command is already defined"));
1015     }
1016
1017   TRY_CATCH (except, RETURN_MASK_ALL)
1018     {
1019       add_setshow_generic (p_smob->type, p_smob->cmd_class,
1020                            p_smob->cmd_name, p_smob,
1021                            p_smob->set_doc, p_smob->show_doc, p_smob->doc,
1022                            (gdbscm_is_procedure (p_smob->set_func)
1023                             ? pascm_set_func : NULL),
1024                            (gdbscm_is_procedure (p_smob->show_func)
1025                             ? pascm_show_func : NULL),
1026                            set_list, show_list,
1027                            &p_smob->set_command, &p_smob->show_command);
1028     }
1029   GDBSCM_HANDLE_GDB_EXCEPTION (except);
1030
1031   /* Note: At this point the parameter exists in gdb.
1032      So no more errors after this point.  */
1033
1034   /* The owner of this parameter is not in GC-controlled memory, so we need
1035      to protect it from GC until the parameter is deleted.  */
1036   scm_gc_protect_object (p_smob->containing_scm);
1037
1038   return SCM_UNSPECIFIED;
1039 }
1040
1041 /* (parameter-value <gdb:parameter>) -> value
1042    (parameter-value <string>) -> value */
1043
1044 static SCM
1045 gdbscm_parameter_value (SCM self)
1046 {
1047   SCM_ASSERT_TYPE (pascm_is_parameter (self) || scm_is_string (self),
1048                    self, SCM_ARG1, FUNC_NAME, _("<gdb:parameter> or string"));
1049
1050   if (pascm_is_parameter (self))
1051     {
1052       param_smob *p_smob = pascm_get_param_smob_arg_unsafe (self, SCM_ARG1,
1053                                                             FUNC_NAME);
1054
1055       return pascm_param_value (p_smob->type, &p_smob->value,
1056                                 SCM_ARG1, FUNC_NAME);
1057     }
1058   else
1059     {
1060       char *name;
1061       SCM except_scm;
1062       struct cmd_list_element *alias, *prefix, *cmd;
1063       const char *arg;
1064       char *newarg;
1065       int found = -1;
1066       volatile struct gdb_exception except;
1067
1068       name = gdbscm_scm_to_host_string (self, NULL, &except_scm);
1069       if (name == NULL)
1070         gdbscm_throw (except_scm);
1071       newarg = concat ("show ", name, (char *) NULL);
1072       TRY_CATCH (except, RETURN_MASK_ALL)
1073         {
1074           found = lookup_cmd_composition (newarg, &alias, &prefix, &cmd);
1075         }
1076       xfree (name);
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, 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, gdbscm_register_parameter_x,
1145     "\
1146 Register a <gdb:parameter> object with GDB." },
1147
1148   { "parameter?", 1, 0, 0, gdbscm_parameter_p,
1149     "\
1150 Return #t if the object is a <gdb:parameter> object." },
1151
1152   { "parameter-value", 1, 0, 0, gdbscm_parameter_value,
1153     "\
1154 Return the value of a <gdb:parameter> object\n\
1155 or any gdb parameter if param is a string naming the parameter." },
1156
1157   { "set-parameter-value!", 2, 0, 0, gdbscm_set_parameter_value_x,
1158     "\
1159 Set the value of a <gdb:parameter> object.\n\
1160 \n\
1161   Arguments: <gdb:parameter> value" },
1162
1163   END_FUNCTIONS
1164 };
1165
1166 void
1167 gdbscm_initialize_parameters (void)
1168 {
1169   parameter_smob_tag
1170     = gdbscm_make_smob_type (param_smob_name, sizeof (param_smob));
1171   scm_set_smob_print (parameter_smob_tag, pascm_print_param_smob);
1172
1173   gdbscm_define_integer_constants (parameter_types, 1);
1174   gdbscm_define_functions (parameter_functions, 1);
1175
1176   command_class_keyword = scm_from_latin1_keyword ("command-class");
1177   parameter_type_keyword = scm_from_latin1_keyword ("parameter-type");
1178   enum_list_keyword = scm_from_latin1_keyword ("enum-list");
1179   set_func_keyword = scm_from_latin1_keyword ("set-func");
1180   show_func_keyword = scm_from_latin1_keyword ("show-func");
1181   doc_keyword = scm_from_latin1_keyword ("doc");
1182   set_doc_keyword = scm_from_latin1_keyword ("set-doc");
1183   show_doc_keyword = scm_from_latin1_keyword ("show-doc");
1184   initial_value_keyword = scm_from_latin1_keyword ("initial-value");
1185   auto_keyword = scm_from_latin1_keyword ("auto");
1186   unlimited_keyword = scm_from_latin1_keyword ("unlimited");
1187 }