Add parameter support for Guile.
authorDoug Evans <xdje42@gmail.com>
Tue, 3 Jun 2014 08:58:15 +0000 (01:58 -0700)
committerDoug Evans <xdje42@gmail.com>
Tue, 3 Jun 2014 08:58:15 +0000 (01:58 -0700)
* Makefile.in (SUBDIR_GUILE_OBS): Add scm-param.o.
(SUBDIR_GUILE_SRCS): Add scm-param.c.
(scm-param.o): New rule.
* guile/guile-internal.h (gdbscm_gc_dup_argv): Declare.
(gdbscm_misc_error): Declare.
(gdbscm_canonicalize_command_name): Declare.
(gdbscm_scm_to_host_string): Declare.
(gdbscm_scm_from_host_string): Declare.
(gdbscm_initialize_parameters): Declare.
* guile/guile.c (initialize_gdb_module): Call
gdbscm_initialize_parameters.
* guile/lib/gdb.scm: Export parameter symbols.
* guile/scm-cmd.c (gdbscm_canonicalize_command_name): Renamed from
cmdscm_canonicalize_name and made public.  All callers updated.
* guile/scm-exception.c (gdbscm_misc_error): New function.
* guile/scm-param.c: New file.
* guile/scm-string.c (gdbscm_scm_to_string): Add comments.
(gdbscm_scm_to_host_string): New function.
(gdbscm_scm_from_host_string): New function.
* scm-utils.c (gdbscm_gc_dup_argv): New function.

testsuite/
* gdb.guile/scm-parameter.exp: New file.

doc/
* guile.texi (Guile API): Add entry for Parameters In Guile.
(GDB Scheme Data Types): Mention <gdb:parameter> object.
(Parameters In Guile): New node.

14 files changed:
gdb/ChangeLog
gdb/Makefile.in
gdb/doc/ChangeLog
gdb/doc/guile.texi
gdb/guile/guile-internal.h
gdb/guile/guile.c
gdb/guile/lib/gdb.scm
gdb/guile/scm-cmd.c
gdb/guile/scm-exception.c
gdb/guile/scm-param.c [new file with mode: 0644]
gdb/guile/scm-string.c
gdb/guile/scm-utils.c
gdb/testsuite/ChangeLog
gdb/testsuite/gdb.guile/scm-parameter.exp [new file with mode: 0644]

index ff829fc..2cf2ed0 100644 (file)
@@ -1,5 +1,29 @@
 2014-06-02  Doug Evans  <xdje42@gmail.com>
 
+       Add parameter support for Guile.
+       * Makefile.in (SUBDIR_GUILE_OBS): Add scm-param.o.
+       (SUBDIR_GUILE_SRCS): Add scm-param.c.
+       (scm-param.o): New rule.
+       * guile/guile-internal.h (gdbscm_gc_dup_argv): Declare.
+       (gdbscm_misc_error): Declare.
+       (gdbscm_canonicalize_command_name): Declare.
+       (gdbscm_scm_to_host_string): Declare.
+       (gdbscm_scm_from_host_string): Declare.
+       (gdbscm_initialize_parameters): Declare.
+       * guile/guile.c (initialize_gdb_module): Call
+       gdbscm_initialize_parameters.
+       * guile/lib/gdb.scm: Export parameter symbols.
+       * guile/scm-cmd.c (gdbscm_canonicalize_command_name): Renamed from
+       cmdscm_canonicalize_name and made public.  All callers updated.
+       * guile/scm-exception.c (gdbscm_misc_error): New function.
+       * guile/scm-param.c: New file.
+       * guile/scm-string.c (gdbscm_scm_to_string): Add comments.
+       (gdbscm_scm_to_host_string): New function.
+       (gdbscm_scm_from_host_string): New function.
+       * scm-utils.c (gdbscm_gc_dup_argv): New function.
+
+2014-06-02  Doug Evans  <xdje42@gmail.com>
+
        Add command support for Guile.
        * Makefile.in (SUBDIR_GUILE_OBS): Add scm-cmd.o.
        (SUBDIR_GUILE_SRCS): Add scm-cmd.c.
index 6159918..c189ea3 100644 (file)
@@ -297,6 +297,7 @@ SUBDIR_GUILE_OBS = \
        scm-lazy-string.o \
        scm-objfile.o \
        scm-math.o \
+       scm-param.o \
        scm-ports.o \
        scm-pretty-print.o \
        scm-progspace.o \
@@ -322,6 +323,7 @@ SUBDIR_GUILE_SRCS = \
        guile/scm-lazy-string.c \
        guile/scm-objfile.c \
        guile/scm-math.c \
+       guile/scm-param.c \
        guile/scm-ports.c \
        guile/scm-pretty-print.c \
        guile/scm-progspace.c \
@@ -2310,6 +2312,10 @@ scm-objfile.o: $(srcdir)/guile/scm-objfile.c
        $(COMPILE) $(srcdir)/guile/scm-objfile.c
        $(POSTCOMPILE)
 
+scm-param.o: $(srcdir)/guile/scm-param.c
+       $(COMPILE) $(srcdir)/guile/scm-param.c
+       $(POSTCOMPILE)
+
 scm-ports.o: $(srcdir)/guile/scm-ports.c
        $(COMPILE) $(srcdir)/guile/scm-ports.c
        $(POSTCOMPILE)
index f2dafe3..ca1d4fe 100644 (file)
@@ -1,5 +1,11 @@
 2014-06-02  Doug Evans  <xdje42@gmail.com>
 
+       * guile.texi (Guile API): Add entry for Parameters In Guile.
+       (GDB Scheme Data Types): Mention <gdb:parameter> object.
+       (Parameters In Guile): New node.
+
+2014-06-02  Doug Evans  <xdje42@gmail.com>
+
        * guile.texi (Guile API): Add entry for Commands In Guile.
        (Basic Guile) <parse-and-eval>: Add reference.
        (Basic Guile) <string->argv>: Move definition to Commands In Guile.
index 70fbd16..3f8c4e4 100644 (file)
@@ -142,6 +142,7 @@ from the Guile interactive prompt.
 * Selecting Guile Pretty-Printers:: How GDB chooses a pretty-printer
 * Writing a Guile Pretty-Printer:: Writing a pretty-printer
 * Commands In Guile::        Implementing new commands in Guile
+* Parameters In Guile::      Adding new @value{GDBN} parameters
 * Progspaces In Guile::      Program spaces
 * Objfiles In Guile::        Object files in Guile
 * Frames In Guile::          Accessing inferior stack frames from Guile
@@ -375,6 +376,9 @@ as a symbol.
 @item <gdb:objfile>
 @xref{Objfiles In Guile}.
 
+@item <gdb:parameter>
+@xref{Parameters In Guile}.
+
 @item <gdb:pretty-printer>
 @xref{Guile Pretty Printing API}.
 
@@ -1946,6 +1950,177 @@ end
 Hello, World!
 @end smallexample
 
+@node Parameters In Guile
+@subsubsection Parameters In Guile
+
+@cindex parameters in guile
+@cindex guile parameters
+@tindex Parameter
+You can implement new @value{GDBN} @dfn{parameters} using Guile
+@footnote{Note that @value{GDBN} parameters must not be confused with
+Guileā€™s parameter objects (@pxref{Parameters,,, guile, GNU Guile
+Reference Manual}).}.
+
+There are many parameters that already exist and can be set in
+@value{GDBN}.  Two examples are: @code{set follow-fork} and
+@code{set charset}.  Setting these parameters influences certain
+behavior in @value{GDBN}.  Similarly, you can define parameters that
+can be used to influence behavior in custom Guile scripts and commands.
+
+A new parameter is defined with the @code{make-parameter} Guile function,
+and added to @value{GDBN} with the @code{register-parameter!} Guile function.
+This two-step approach is taken to separate out the side-effect of adding
+the parameter to @value{GDBN} from @code{make-parameter}.
+
+Parameters are exposed to the user via the @code{set} and
+@code{show} commands.  @xref{Help}.
+
+@c TODO line length
+@deffn {Scheme Procedure} (make-parameter name @r{[}#:command-class command-class@r{]} @r{[}#:parameter-type parameter-type{]} @r{[}#:enum-list enum-list@r{]} @r{[}#:set-func set-func{]} @r{[}#:show-func show-func{]} @r{[}#:doc doc{]} @r{[}#:set-doc set-doc{]} @r{[}#:show-doc show-doc{]} @r{[}#:initial-value initial-value{]})
+
+The argument @var{name} is the name of the new parameter.  If @var{name}
+consists of multiple words, then the initial words are looked for as prefix
+parameters.  An example of this can be illustrated with the
+@code{set print} set of parameters.  If @var{name} is
+@code{print foo}, then @code{print} will be searched as the prefix
+parameter.  In this case the parameter can subsequently be accessed in
+@value{GDBN} as @code{set print foo}.
+If @var{name} consists of multiple words, and no prefix parameter group
+can be found, an exception is raised.
+
+The result is the @code{<gdb:parameter>} object representing the parameter.
+The parameter is not usable until it has been registered with @value{GDBN}
+with @code{register-parameter!}.
+
+The rest of the arguments are optional.
+
+The argument @var{command-class} should be one of the @samp{COMMAND_} constants
+(@pxref{Commands In Guile}).  This argument tells @value{GDBN} how to
+categorize the new parameter in the help system.
+The default is @code{COMMAND_NONE}.
+
+The argument @var{parameter-type} should be one of the @samp{PARAM_} constants
+defined below.  This argument tells @value{GDBN} the type of the new
+parameter; this information is used for input validation and
+completion.  The default is @code{PARAM_BOOLEAN}.
+
+If @var{parameter-type} is @code{PARAM_ENUM}, then
+@var{enum-list} must be a list of strings.  These strings
+represent the possible values for the parameter.
+
+If @var{parameter-type} is not @code{PARAM_ENUM}, then the presence
+of @var{enum-list} will cause an exception to be thrown.
+
+The argument @var{set-func} is a function of one argument: @var{self} which
+is the @code{<gdb:parameter>} object representing the parameter.
+@value{GDBN} will call this function when a @var{parameter}'s value has
+been changed via the @code{set} API (for example, @kbd{set foo off}).
+The value of the parameter has already been set to the new value.
+This function must return a string to be displayed to the user.
+@value{GDBN} will add a trailing newline if the string is non-empty.
+@value{GDBN} generally doesn't print anything when a parameter is set,
+thus typically this function should return @samp{""}.
+A non-empty string result should typically be used for displaying warnings
+and errors.
+
+The argument @var{show-func} is a function of two arguments: @var{self} which
+is the @code{<gdb:parameter>} object representing the parameter, and
+@var{svalue} which is the string representation of the current value.
+@value{GDBN} will call this function when a @var{parameter}'s
+@code{show} API has been invoked (for example, @kbd{show foo}).
+This function must return a string, and will be displayed to the user.
+@value{GDBN} will add a trailing newline.
+
+The argument @var{doc} is the help text for the new parameter.
+If there is no documentation string, a default value is used.
+
+The argument @var{set-doc} is the help text for this parameter's
+@code{set} command.
+
+The argument @var{show-doc} is the help text for this parameter's
+@code{show} command.
+
+The argument @var{initial-value} specifies the initial value of the parameter.
+If it is a function, it takes one parameter, the @code{<gdb:parameter>}
+object and its result is used as the initial value of the parameter.
+The initial value must be valid for the parameter type,
+otherwise an exception is thrown.
+@end deffn
+
+@deffn {Scheme Procedure} register-parameter! parameter
+Add @var{parameter}, a @code{<gdb:parameter>} object, to @value{GDBN}'s
+list of parameters.
+It is an error to register a parameter more than once.
+The result is unspecified.
+@end deffn
+
+@deffn {Scheme Procedure} parameter? object
+Return @code{#t} if @var{object} is a @code{<gdb:parameter>} object.
+Otherwise return @code{#f}.
+@end deffn
+
+@deffn {Scheme Procedure} parameter-value parameter
+Return the value of @var{parameter} which may either be
+a @code{<gdb:parameter>} object or a string naming the parameter.
+@end deffn
+
+@deffn {Scheme Procedure} set-parameter-value! parameter new-value
+Assign @var{parameter} the value of @var{new-value}.
+The argument @var{parameter} must be an object of type @code{<gdb:parameter>}.
+@value{GDBN} does validation when assignments are made.
+@end deffn
+
+When a new parameter is defined, its type must be specified.  The
+available types are represented by constants defined in the @code{gdb}
+module:
+
+@vtable @code
+@item PARAM_BOOLEAN
+The value is a plain boolean.  The Guile boolean values, @code{#t}
+and @code{#f} are the only valid values.
+
+@item PARAM_AUTO_BOOLEAN
+The value has three possible states: true, false, and @samp{auto}.  In
+Guile, true and false are represented using boolean constants, and
+@samp{auto} is represented using @code{#:auto}.
+
+@item PARAM_UINTEGER
+The value is an unsigned integer.  The value of 0 should be
+interpreted to mean ``unlimited''.
+
+@item PARAM_ZINTEGER
+The value is an integer.
+
+@item PARAM_ZUINTEGER
+The value is an unsigned integer.
+
+@item PARAM_ZUINTEGER_UNLIMITED
+The value is an integer in the range @samp{[0, INT_MAX]}.
+A value of @samp{-1} means ``unlimited'', and other negative
+numbers are not allowed.
+
+@item PARAM_STRING
+The value is a string.  When the user modifies the string, any escape
+sequences, such as @samp{\t}, @samp{\f}, and octal escapes, are
+translated into corresponding characters and encoded into the current
+host charset.
+
+@item PARAM_STRING_NOESCAPE
+The value is a string.  When the user modifies the string, escapes are
+passed through untranslated.
+
+@item PARAM_OPTIONAL_FILENAME
+The value is a either a filename (a string), or @code{#f}.
+
+@item PARAM_FILENAME
+The value is a filename.  This is just like
+@code{PARAM_STRING_NOESCAPE}, but uses file names for completion.
+
+@item PARAM_ENUM
+The value is a string, which must be one of a collection of string
+constants provided when the parameter is created.
+@end vtable
+
 @node Progspaces In Guile
 @subsubsection Program Spaces In Guile
 
index 042ece9..03a2b1e 100644 (file)
@@ -166,6 +166,8 @@ extern void gdbscm_dynwind_xfree (void *ptr);
 extern int gdbscm_is_procedure (SCM proc);
 
 extern char *gdbscm_gc_xstrdup (const char *);
+
+extern const char * const *gdbscm_gc_dup_argv (char **argv);
 \f
 /* GDB smobs, from scm-gsmob.c */
 
@@ -301,6 +303,10 @@ extern void gdbscm_out_of_range_error (const char *subr, int arg_pos,
 extern SCM gdbscm_make_misc_error (const char *subr, int arg_pos,
                                   SCM bad_value, const char *error);
 
+extern void gdbscm_misc_error (const char *subr, int arg_pos,
+                              SCM bad_value, const char *error)
+   ATTRIBUTE_NORETURN;
+
 extern void gdbscm_throw (SCM exception) ATTRIBUTE_NORETURN;
 
 extern SCM gdbscm_scm_from_gdb_exception (struct gdb_exception exception);
@@ -388,6 +394,9 @@ extern char *gdbscm_parse_command_name (const char *name,
 
 extern int gdbscm_valid_command_class_p (int command_class);
 
+extern char *gdbscm_canonicalize_command_name (const char *name,
+                                              int want_trailing_space);
+
 /* scm-frame.c */
 
 typedef struct _frame_smob frame_smob;
@@ -476,6 +485,10 @@ extern char *gdbscm_scm_to_string (SCM string, size_t *lenp,
 extern SCM gdbscm_scm_from_string (const char *string, size_t len,
                                   const char *charset, int strict);
 
+extern char *gdbscm_scm_to_host_string (SCM string, size_t *lenp, SCM *except);
+
+extern SCM gdbscm_scm_from_host_string (const char *string, size_t len);
+
 /* scm-symbol.c */
 
 extern int syscm_is_symbol (SCM scm);
@@ -565,6 +578,7 @@ extern void gdbscm_initialize_lazy_strings (void);
 extern void gdbscm_initialize_math (void);
 extern void gdbscm_initialize_objfiles (void);
 extern void gdbscm_initialize_pretty_printers (void);
+extern void gdbscm_initialize_parameters (void);
 extern void gdbscm_initialize_ports (void);
 extern void gdbscm_initialize_pspaces (void);
 extern void gdbscm_initialize_smobs (void);
index c4e5832..00d7b06 100644 (file)
@@ -544,6 +544,7 @@ initialize_gdb_module (void *data)
   gdbscm_initialize_lazy_strings ();
   gdbscm_initialize_math ();
   gdbscm_initialize_objfiles ();
+  gdbscm_initialize_parameters ();
   gdbscm_initialize_ports ();
   gdbscm_initialize_pretty_printers ();
   gdbscm_initialize_pspaces ();
index a3f43a4..f81433b 100644 (file)
  current-objfile
  objfiles
 
+ ;; scm-param.c
+
+ PARAM_BOOLEAN
+ PARAM_AUTO_BOOLEAN
+ PARAM_ZINTEGER
+ PARAM_UINTEGER
+ PARAM_ZUINTEGER
+ PARAM_ZUINTEGER_UNLIMITED
+ PARAM_STRING
+ PARAM_STRING_NOESCAPE
+ PARAM_OPTIONAL_FILENAME
+ PARAM_FILENAME
+ PARAM_ENUM
+
+ make-parameter
+ register-parameter!
+ parameter?
+ parameter-value
+ set-parameter-value!
+
  ;; scm-ports.c
 
  input-port
index ee3674c..57979c8 100644 (file)
@@ -603,8 +603,8 @@ gdbscm_valid_command_class_p (int command_class)
    but that is the caller's responsibility.
    Space for the result is allocated on the GC heap.  */
 
-static char *
-cmdscm_canonicalize_name (const char *name, int want_trailing_space)
+char *
+gdbscm_canonicalize_command_name (const char *name, int want_trailing_space)
 {
   int i, out, seen_word;
   char *result = scm_gc_malloc_pointerless (strlen (name) + 2, FUNC_NAME);
@@ -699,7 +699,7 @@ gdbscm_make_command (SCM name_scm, SCM rest)
     doc = xstrdup (_("This command is not documented."));
 
   s = name;
-  name = cmdscm_canonicalize_name (s, is_prefix);
+  name = gdbscm_canonicalize_command_name (s, is_prefix);
   xfree (s);
   s = doc;
   doc = gdbscm_gc_xstrdup (s);
index 0f3c875..05f9617 100644 (file)
@@ -360,12 +360,23 @@ gdbscm_out_of_range_error (const char *subr, int arg_pos, SCM bad_value,
 
 SCM
 gdbscm_make_misc_error (const char *subr, int arg_pos, SCM bad_value,
-                      const char *error)
+                       const char *error)
 {
   return gdbscm_make_arg_error (scm_misc_error_key,
                                subr, arg_pos, bad_value, NULL, error);
 }
 
+/* Throw a misc-error error.  */
+
+void
+gdbscm_misc_error (const char *subr, int arg_pos, SCM bad_value,
+                  const char *error)
+{
+  SCM exception = gdbscm_make_misc_error (subr, arg_pos, bad_value, error);
+
+  gdbscm_throw (exception);
+}
+
 /* Return a <gdb:exception> object for gdb:memory-error.  */
 
 SCM
diff --git a/gdb/guile/scm-param.c b/gdb/guile/scm-param.c
new file mode 100644 (file)
index 0000000..ab2efd1
--- /dev/null
@@ -0,0 +1,1163 @@
+/* GDB parameters implemented in Guile.
+
+   Copyright (C) 2008-2014 Free Software Foundation, Inc.
+
+   This file is part of GDB.
+
+   This program is free software; you can redistribute it and/or modify
+   it under the terms of the GNU General Public License as published by
+   the Free Software Foundation; either version 3 of the License, or
+   (at your option) any later version.
+
+   This program is distributed in the hope that it will be useful,
+   but WITHOUT ANY WARRANTY; without even the implied warranty of
+   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+   GNU General Public License for more details.
+
+   You should have received a copy of the GNU General Public License
+   along with this program.  If not, see <http://www.gnu.org/licenses/>.  */
+
+#include "defs.h"
+#include "value.h"
+#include "exceptions.h"
+#include "charset.h"
+#include "gdbcmd.h"
+#include "cli/cli-decode.h"
+#include "completer.h"
+#include "language.h"
+#include "arch-utils.h"
+#include "guile-internal.h"
+
+/* A union that can hold anything described by enum var_types.  */
+
+union pascm_variable
+{
+  /* Hold an integer value, for boolean and integer types.  */
+  int intval;
+
+  /* Hold an auto_boolean.  */
+  enum auto_boolean autoboolval;
+
+  /* Hold an unsigned integer value, for uinteger.  */
+  unsigned int uintval;
+
+  /* Hold a string, for the various string types.  */
+  char *stringval;
+
+  /* Hold a string, for enums.  */
+  const char *cstringval;
+};
+
+/* A GDB parameter.
+
+   Note: Parameters are added to gdb using a two step process:
+   1) Call make-parameter to create a <gdb:parameter> object.
+   2) Call register-parameter! to add the parameter to gdb.
+   It is done this way so that the constructor, make-parameter, doesn't have
+   any side-effects.  This means that the smob needs to store everything
+   that was passed to make-parameter.
+
+   N.B. There is no free function for this smob.
+   All objects pointed to by this smob must live in GC space.  */
+
+typedef struct _param_smob
+{
+  /* This always appears first.  */
+  gdb_smob base;
+
+  /* The parameter name.  */
+  char *name;
+
+  /* The last word of the command.
+     This is needed because add_cmd requires us to allocate space
+     for it. :-(  */
+  char *cmd_name;
+
+  /* One of the COMMAND_* constants.  */
+  enum command_class cmd_class;
+
+  /* The type of the parameter.  */
+  enum var_types type;
+
+  /* The docs for the parameter.  */
+  char *set_doc;
+  char *show_doc;
+  char *doc;
+
+  /* The corresponding gdb command objects.
+     These are NULL if the parameter has not been registered yet, or
+     is no longer registered.  */
+  struct cmd_list_element *set_command;
+  struct cmd_list_element *show_command;
+
+  /* The value of the parameter.  */
+  union pascm_variable value;
+
+  /* For an enum parameter, the possible values.  The vector lives in GC
+     space, it will be freed with the smob.  */
+  const char * const *enumeration;
+
+  /* The set_func funcion or #f if not specified.
+     This function is called *after* the parameter is set.
+     It returns a string that will be displayed to the user.  */
+  SCM set_func;
+
+  /* The show_func function or #f if not specified.
+     This function returns the string that is printed.  */
+  SCM show_func;
+
+  /* The <gdb:parameter> object we are contained in, needed to
+     protect/unprotect the object since a reference to it comes from
+     non-gc-managed space (the command context pointer).  */
+  SCM containing_scm;
+} param_smob;
+
+static const char param_smob_name[] = "gdb:parameter";
+
+/* The tag Guile knows the param smob by.  */
+static scm_t_bits parameter_smob_tag;
+
+/* Keywords used by make-parameter!.  */
+static SCM command_class_keyword;
+static SCM parameter_type_keyword;
+static SCM enum_list_keyword;
+static SCM set_func_keyword;
+static SCM show_func_keyword;
+static SCM doc_keyword;
+static SCM set_doc_keyword;
+static SCM show_doc_keyword;
+static SCM initial_value_keyword;
+static SCM auto_keyword;
+static SCM unlimited_keyword;
+
+static int pascm_is_valid (param_smob *);
+static const char *pascm_param_type_name (enum var_types type);
+static SCM pascm_param_value (enum var_types type, void *var,
+                             int arg_pos, const char *func_name);
+\f
+/* Administrivia for parameter smobs.  */
+
+static int
+pascm_print_param_smob (SCM self, SCM port, scm_print_state *pstate)
+{
+  param_smob *p_smob = (param_smob *) SCM_SMOB_DATA (self);
+  SCM value;
+
+  gdbscm_printf (port, "#<%s", param_smob_name);
+
+  gdbscm_printf (port, " %s", p_smob->name);
+
+  if (! pascm_is_valid (p_smob))
+    scm_puts (" {invalid}", port);
+
+  gdbscm_printf (port, " %s", pascm_param_type_name (p_smob->type));
+
+  value = pascm_param_value (p_smob->type, &p_smob->value,
+                            GDBSCM_ARG_NONE, NULL);
+  scm_display (value, port);
+
+  scm_puts (">", port);
+
+  scm_remember_upto_here_1 (self);
+
+  /* Non-zero means success.  */
+  return 1;
+}
+
+/* Create an empty (uninitialized) parameter.  */
+
+static SCM
+pascm_make_param_smob (void)
+{
+  param_smob *p_smob = (param_smob *)
+    scm_gc_malloc (sizeof (param_smob), param_smob_name);
+  SCM p_scm;
+
+  memset (p_smob, 0, sizeof (*p_smob));
+  p_smob->cmd_class = no_class;
+  p_smob->type = var_boolean;
+  p_smob->set_func = SCM_BOOL_F;
+  p_smob->show_func = SCM_BOOL_F;
+  p_scm = scm_new_smob (parameter_smob_tag, (scm_t_bits) p_smob);
+  p_smob->containing_scm = p_scm;
+  gdbscm_init_gsmob (&p_smob->base);
+
+  return p_scm;
+}
+
+/* Returns non-zero if SCM is a <gdb:parameter> object.  */
+
+static int
+pascm_is_parameter (SCM scm)
+{
+  return SCM_SMOB_PREDICATE (parameter_smob_tag, scm);
+}
+
+/* (gdb:parameter? scm) -> boolean */
+
+static SCM
+gdbscm_parameter_p (SCM scm)
+{
+  return scm_from_bool (pascm_is_parameter (scm));
+}
+
+/* Returns the <gdb:parameter> object in SELF.
+   Throws an exception if SELF is not a <gdb:parameter> object.  */
+
+static SCM
+pascm_get_param_arg_unsafe (SCM self, int arg_pos, const char *func_name)
+{
+  SCM_ASSERT_TYPE (pascm_is_parameter (self), self, arg_pos, func_name,
+                  param_smob_name);
+
+  return self;
+}
+
+/* Returns a pointer to the parameter smob of SELF.
+   Throws an exception if SELF is not a <gdb:parameter> object.  */
+
+static param_smob *
+pascm_get_param_smob_arg_unsafe (SCM self, int arg_pos, const char *func_name)
+{
+  SCM p_scm = pascm_get_param_arg_unsafe (self, arg_pos, func_name);
+  param_smob *p_smob = (param_smob *) SCM_SMOB_DATA (p_scm);
+
+  return p_smob;
+}
+
+/* Return non-zero if parameter P_SMOB is valid.  */
+
+static int
+pascm_is_valid (param_smob *p_smob)
+{
+  return p_smob->set_command != NULL;
+}
+\f
+/* A helper function which return the default documentation string for
+   a parameter (which is to say that it's undocumented).  */
+
+static char *
+get_doc_string (void)
+{
+  return xstrdup (_("This command is not documented."));
+}
+
+/* Subroutine of pascm_set_func, pascm_show_func to simplify them.
+   Signal the error returned from calling set_func/show_func.  */
+
+static void
+pascm_signal_setshow_error (SCM exception, const char *msg)
+{
+  /* Don't print the stack if this was an error signalled by the command
+     itself.  */
+  if (gdbscm_user_error_p (gdbscm_exception_key (exception)))
+    {
+      char *excp_text = gdbscm_exception_message_to_string (exception);
+
+      make_cleanup (xfree, excp_text);
+      error ("%s", excp_text);
+    }
+  else
+    {
+      gdbscm_print_gdb_exception (SCM_BOOL_F, exception);
+      error ("%s", msg);
+    }
+}
+
+/* A callback function that is registered against the respective
+   add_setshow_* set_func prototype.  This function will call
+   the Scheme function "set_func" which must exist.
+   Note: ARGS is always passed as NULL.  */
+
+static void
+pascm_set_func (char *args, int from_tty, struct cmd_list_element *c)
+{
+  param_smob *p_smob = (param_smob *) get_cmd_context (c);
+  SCM self, result, exception;
+  char *msg;
+  struct cleanup *cleanups;
+
+  gdb_assert (gdbscm_is_procedure (p_smob->set_func));
+
+  self = p_smob->containing_scm;
+
+  result = gdbscm_safe_call_1 (p_smob->set_func, self, gdbscm_user_error_p);
+
+  if (gdbscm_is_exception (result))
+    {
+      pascm_signal_setshow_error (result,
+                                 _("Error occurred setting parameter."));
+    }
+
+  if (!scm_is_string (result))
+    error (_("Result of %s set-func is not a string."), p_smob->name);
+
+  msg = gdbscm_scm_to_host_string (result, NULL, &exception);
+  if (msg == NULL)
+    {
+      gdbscm_print_gdb_exception (SCM_BOOL_F, exception);
+      error (_("Error converting show text to host string."));
+    }
+
+  cleanups = make_cleanup (xfree, msg);
+  /* GDB is usually silent when a parameter is set.  */
+  if (*msg != '\0')
+    fprintf_filtered (gdb_stdout, "%s\n", msg);
+  do_cleanups (cleanups);
+}
+
+/* A callback function that is registered against the respective
+   add_setshow_* show_func prototype.  This function will call
+   the Scheme function "show_func" which must exist and must return a
+   string that is then printed to FILE.  */
+
+static void
+pascm_show_func (struct ui_file *file, int from_tty,
+                struct cmd_list_element *c, const char *value)
+{
+  param_smob *p_smob = (param_smob *) get_cmd_context (c);
+  SCM value_scm, self, result, exception;
+  char *msg;
+  struct cleanup *cleanups;
+
+  gdb_assert (gdbscm_is_procedure (p_smob->show_func));
+
+  value_scm = gdbscm_scm_from_host_string (value, strlen (value));
+  if (gdbscm_is_exception (value_scm))
+    {
+      error (_("Error converting parameter value \"%s\" to Scheme string."),
+            value);
+    }
+  self = p_smob->containing_scm;
+
+  result = gdbscm_safe_call_2 (p_smob->show_func, self, value_scm,
+                              gdbscm_user_error_p);
+
+  if (gdbscm_is_exception (result))
+    {
+      pascm_signal_setshow_error (result,
+                                 _("Error occurred showing parameter."));
+    }
+
+  msg = gdbscm_scm_to_host_string (result, NULL, &exception);
+  if (msg == NULL)
+    {
+      gdbscm_print_gdb_exception (SCM_BOOL_F, exception);
+      error (_("Error converting show text to host string."));
+    }
+
+  cleanups = make_cleanup (xfree, msg);
+  fprintf_filtered (file, "%s\n", msg);
+  do_cleanups (cleanups);
+}
+
+/* A helper function that dispatches to the appropriate add_setshow
+   function.  */
+
+static void
+add_setshow_generic (enum var_types param_type, enum command_class cmd_class,
+                    char *cmd_name, param_smob *self,
+                    char *set_doc, char *show_doc, char *help_doc,
+                    cmd_sfunc_ftype *set_func,
+                    show_value_ftype *show_func,
+                    struct cmd_list_element **set_list,
+                    struct cmd_list_element **show_list,
+                    struct cmd_list_element **set_cmd,
+                    struct cmd_list_element **show_cmd)
+{
+  struct cmd_list_element *param = NULL;
+  const char *tmp_name = NULL;
+
+  switch (param_type)
+    {
+    case var_boolean:
+      add_setshow_boolean_cmd (cmd_name, cmd_class,
+                              &self->value.intval,
+                              set_doc, show_doc, help_doc,
+                              set_func, show_func,
+                              set_list, show_list);
+
+      break;
+
+    case var_auto_boolean:
+      add_setshow_auto_boolean_cmd (cmd_name, cmd_class,
+                                   &self->value.autoboolval,
+                                   set_doc, show_doc, help_doc,
+                                   set_func, show_func,
+                                   set_list, show_list);
+      break;
+
+    case var_uinteger:
+      add_setshow_uinteger_cmd (cmd_name, cmd_class,
+                               &self->value.uintval,
+                               set_doc, show_doc, help_doc,
+                               set_func, show_func,
+                               set_list, show_list);
+      break;
+
+    case var_zinteger:
+      add_setshow_zinteger_cmd (cmd_name, cmd_class,
+                               &self->value.intval,
+                               set_doc, show_doc, help_doc,
+                               set_func, show_func,
+                               set_list, show_list);
+      break;
+
+    case var_zuinteger:
+      add_setshow_zuinteger_cmd (cmd_name, cmd_class,
+                                &self->value.uintval,
+                                set_doc, show_doc, help_doc,
+                                set_func, show_func,
+                                set_list, show_list);
+      break;
+
+    case var_zuinteger_unlimited:
+      add_setshow_zuinteger_unlimited_cmd (cmd_name, cmd_class,
+                                          &self->value.intval,
+                                          set_doc, show_doc, help_doc,
+                                          set_func, show_func,
+                                          set_list, show_list);
+      break;
+
+    case var_string:
+      add_setshow_string_cmd (cmd_name, cmd_class,
+                             &self->value.stringval,
+                             set_doc, show_doc, help_doc,
+                             set_func, show_func,
+                             set_list, show_list);
+      break;
+
+    case var_string_noescape:
+      add_setshow_string_noescape_cmd (cmd_name, cmd_class,
+                                      &self->value.stringval,
+                                      set_doc, show_doc, help_doc,
+                                      set_func, show_func,
+                                      set_list, show_list);
+
+      break;
+
+    case var_optional_filename:
+      add_setshow_optional_filename_cmd (cmd_name, cmd_class,
+                                        &self->value.stringval,
+                                        set_doc, show_doc, help_doc,
+                                        set_func, show_func,
+                                        set_list, show_list);
+      break;
+
+    case var_filename:
+      add_setshow_filename_cmd (cmd_name, cmd_class,
+                               &self->value.stringval,
+                               set_doc, show_doc, help_doc,
+                               set_func, show_func,
+                               set_list, show_list);
+      break;
+
+    case var_enum:
+      add_setshow_enum_cmd (cmd_name, cmd_class,
+                           self->enumeration,
+                           &self->value.cstringval,
+                           set_doc, show_doc, help_doc,
+                           set_func, show_func,
+                           set_list, show_list);
+      /* Initialize the value, just in case.  */
+      self->value.cstringval = self->enumeration[0];
+      break;
+
+    default:
+      gdb_assert_not_reached ("bad param_type value");
+    }
+
+  /* Lookup created parameter, and register Scheme object against the
+     parameter context.  Perform this task against both lists.  */
+  tmp_name = cmd_name;
+  param = lookup_cmd (&tmp_name, *show_list, "", 0, 1);
+  gdb_assert (param != NULL);
+  set_cmd_context (param, self);
+  *set_cmd = param;
+
+  tmp_name = cmd_name;
+  param = lookup_cmd (&tmp_name, *set_list, "", 0, 1);
+  gdb_assert (param != NULL);
+  set_cmd_context (param, self);
+  *show_cmd = param;
+}
+
+/* Return an array of strings corresponding to the enum values for
+   ENUM_VALUES_SCM.
+   Throws an exception if there's a problem with the values.
+   Space for the result is allocated from the GC heap.  */
+
+static const char * const *
+compute_enum_list (SCM enum_values_scm, int arg_pos, const char *func_name)
+{
+  long i, size;
+  char **enum_values;
+  const char * const *result;
+
+  SCM_ASSERT_TYPE (gdbscm_is_true (scm_list_p (enum_values_scm)),
+                  enum_values_scm, arg_pos, func_name, _("list"));
+
+  size = scm_ilength (enum_values_scm);
+  if (size == 0)
+    {
+      gdbscm_out_of_range_error (FUNC_NAME, arg_pos, enum_values_scm,
+                                _("enumeration list is empty"));
+    }
+
+  enum_values = xmalloc ((size + 1) * sizeof (char *));
+  memset (enum_values, 0, (size + 1) * sizeof (char *));
+
+  i = 0;
+  while (!scm_is_eq (enum_values_scm, SCM_EOL))
+    {
+      SCM value = scm_car (enum_values_scm);
+      SCM exception;
+
+      if (!scm_is_string (value))
+       {
+         freeargv (enum_values);
+         SCM_ASSERT_TYPE (0, value, arg_pos, func_name, _("string"));
+       }
+      enum_values[i] = gdbscm_scm_to_host_string (value, NULL, &exception);
+      if (enum_values[i] == NULL)
+       {
+         freeargv (enum_values);
+         gdbscm_throw (exception);
+       }
+      ++i;
+      enum_values_scm = scm_cdr (enum_values_scm);
+    }
+  gdb_assert (i == size);
+
+  result = gdbscm_gc_dup_argv (enum_values);
+  freeargv (enum_values);
+  return result;
+}
+
+static const scheme_integer_constant parameter_types[] =
+{
+  /* Note: var_integer is deprecated, and intentionally does not
+     appear here.  */
+  { "PARAM_BOOLEAN", var_boolean }, /* ARI: var_boolean */
+  { "PARAM_AUTO_BOOLEAN", var_auto_boolean },
+  { "PARAM_ZINTEGER", var_zinteger },
+  { "PARAM_UINTEGER", var_uinteger },
+  { "PARAM_ZUINTEGER", var_zuinteger },
+  { "PARAM_ZUINTEGER_UNLIMITED", var_zuinteger_unlimited },
+  { "PARAM_STRING", var_string },
+  { "PARAM_STRING_NOESCAPE", var_string_noescape },
+  { "PARAM_OPTIONAL_FILENAME", var_optional_filename },
+  { "PARAM_FILENAME", var_filename },
+  { "PARAM_ENUM", var_enum },
+
+  END_INTEGER_CONSTANTS
+};
+
+/* Return non-zero if PARAM_TYPE is a valid parameter type.  */
+
+static int
+pascm_valid_parameter_type_p (int param_type)
+{
+  int i;
+
+  for (i = 0; parameter_types[i].name != NULL; ++i)
+    {
+      if (parameter_types[i].value == param_type)
+       return 1;
+    }
+
+  return 0;
+}
+
+/* Return PARAM_TYPE as a string.  */
+
+static const char *
+pascm_param_type_name (enum var_types param_type)
+{
+  int i;
+
+  for (i = 0; parameter_types[i].name != NULL; ++i)
+    {
+      if (parameter_types[i].value == param_type)
+       return parameter_types[i].name;
+    }
+
+  gdb_assert_not_reached ("bad parameter type");
+}
+
+/* Return the value of a gdb parameter as a Scheme value.
+   If TYPE is not supported, then a <gdb:exception> object is returned.  */
+
+static SCM
+pascm_param_value (enum var_types type, void *var,
+                  int arg_pos, const char *func_name)
+{
+  /* Note: We *could* support var_integer here in case someone is trying to get
+     the value of a Python-created parameter (which is the only place that
+     still supports var_integer).  To further discourage its use we do not.  */
+
+  switch (type)
+    {
+    case var_string:
+    case var_string_noescape:
+    case var_optional_filename:
+    case var_filename:
+    case var_enum:
+      {
+       char *str = * (char **) var;
+
+       if (str == NULL)
+         str = "";
+       return gdbscm_scm_from_host_string (str, strlen (str));
+      }
+
+    case var_boolean:
+      {
+       if (* (int *) var)
+         return SCM_BOOL_T;
+       else
+         return SCM_BOOL_F;
+      }
+
+    case var_auto_boolean:
+      {
+       enum auto_boolean ab = * (enum auto_boolean *) var;
+
+       if (ab == AUTO_BOOLEAN_TRUE)
+         return SCM_BOOL_T;
+       else if (ab == AUTO_BOOLEAN_FALSE)
+         return SCM_BOOL_F;
+       else
+         return auto_keyword;
+      }
+
+    case var_zuinteger_unlimited:
+      if (* (int *) var == -1)
+       return unlimited_keyword;
+      gdb_assert (* (int *) var >= 0);
+      /* Fall through.  */
+    case var_zinteger:
+      return scm_from_int (* (int *) var);
+
+    case var_uinteger:
+      if (* (unsigned int *) var == UINT_MAX)
+       return unlimited_keyword;
+      /* Fall through.  */
+    case var_zuinteger:
+      return scm_from_uint (* (unsigned int *) var);
+
+    default:
+      break;
+    }
+
+  return gdbscm_make_out_of_range_error (func_name, arg_pos,
+                                        scm_from_int (type),
+                                        _("program error: unhandled type"));
+}
+
+/* Set the value of a parameter of type TYPE in VAR from VALUE.
+   ENUMERATION is the list of enum values for enum parameters, otherwise NULL.
+   Throws a Scheme exception if VALUE_SCM is invalid for TYPE.  */
+
+static void
+pascm_set_param_value_x (enum var_types type, union pascm_variable *var,
+                        const char * const *enumeration,
+                        SCM value, int arg_pos, const char *func_name)
+{
+  switch (type)
+    {
+    case var_string:
+    case var_string_noescape:
+    case var_optional_filename:
+    case var_filename:
+      SCM_ASSERT_TYPE (scm_is_string (value)
+                      || (type != var_filename
+                          && gdbscm_is_false (value)),
+                      value, arg_pos, func_name,
+                      _("string or #f for non-PARAM_FILENAME parameters"));
+      if (gdbscm_is_false (value))
+       {
+         xfree (var->stringval);
+         if (type == var_optional_filename)
+           var->stringval = xstrdup ("");
+         else
+           var->stringval = NULL;
+       }
+      else
+       {
+         char *string;
+         SCM exception;
+
+         string = gdbscm_scm_to_host_string (value, NULL, &exception);
+         if (string == NULL)
+           gdbscm_throw (exception);
+         xfree (var->stringval);
+         var->stringval = string;
+       }
+      break;
+
+    case var_enum:
+      {
+       int i;
+       char *str;
+       SCM exception;
+
+       SCM_ASSERT_TYPE (scm_is_string (value), value, arg_pos, func_name,
+                      _("string"));
+       str = gdbscm_scm_to_host_string (value, NULL, &exception);
+       if (str == NULL)
+         gdbscm_throw (exception);
+       for (i = 0; enumeration[i]; ++i)
+         {
+           if (strcmp (enumeration[i], str) == 0)
+             break;
+         }
+       xfree (str);
+       if (enumeration[i] == NULL)
+         {
+           gdbscm_out_of_range_error (func_name, arg_pos, value,
+                                      _("not member of enumeration"));
+         }
+       var->cstringval = enumeration[i];
+       break;
+      }
+
+    case var_boolean:
+      SCM_ASSERT_TYPE (gdbscm_is_bool (value), value, arg_pos, func_name,
+                      _("boolean"));
+      var->intval = gdbscm_is_true (value);
+      break;
+
+    case var_auto_boolean:
+      SCM_ASSERT_TYPE (gdbscm_is_bool (value)
+                      || scm_is_eq (value, auto_keyword),
+                      value, arg_pos, func_name,
+                      _("boolean or #:auto"));
+      if (scm_is_eq (value, auto_keyword))
+       var->autoboolval = AUTO_BOOLEAN_AUTO;
+      else if (gdbscm_is_true (value))
+       var->autoboolval = AUTO_BOOLEAN_TRUE;
+      else
+       var->autoboolval = AUTO_BOOLEAN_FALSE;
+      break;
+
+    case var_zinteger:
+    case var_uinteger:
+    case var_zuinteger:
+    case var_zuinteger_unlimited:
+      if (type == var_uinteger
+         || type == var_zuinteger_unlimited)
+       {
+         SCM_ASSERT_TYPE (gdbscm_is_bool (value)
+                          || scm_is_eq (value, unlimited_keyword),
+                          value, arg_pos, func_name,
+                          _("integer or #:unlimited"));
+         if (scm_is_eq (value, unlimited_keyword))
+           {
+             if (type == var_uinteger)
+               var->intval = UINT_MAX;
+             else
+               var->intval = -1;
+             break;
+           }
+       }
+      else
+       {
+         SCM_ASSERT_TYPE (scm_is_integer (value), value, arg_pos, func_name,
+                          _("integer"));
+       }
+
+      if (type == var_uinteger
+         || type == var_zuinteger)
+       {
+         unsigned int u = scm_to_uint (value);
+
+         if (type == var_uinteger && u == 0)
+           u = UINT_MAX;
+         var->uintval = u;
+       }
+      else
+       {
+         int i = scm_to_int (value);
+
+         if (type == var_zuinteger_unlimited && i < -1)
+           {
+             gdbscm_out_of_range_error (func_name, arg_pos, value,
+                                        _("must be >= -1"));
+           }
+         var->intval = i;
+       }
+      break;
+
+    default:
+      gdb_assert_not_reached ("bad parameter type");
+    }
+}
+\f
+/* Parameter Scheme functions.  */
+
+/* (make-parameter name
+     [#:command-class cmd-class] [#:parameter-type param-type]
+     [#:enum-list enum-list] [#:set-func function] [#:show-func function]
+     [#:doc <string>] [#:set-doc <string>] [#:show-doc <string>]
+     [#:initial-value initial-value]) -> <gdb:parameter>
+
+   NAME is the name of the parameter.  It may consist of multiple
+   words, in which case the final word is the name of the new parameter,
+   and earlier words must be prefix commands.
+
+   CMD-CLASS is the kind of command.  It should be one of the COMMAND_*
+   constants defined in the gdb module.
+
+   PARAM_TYPE is the type of the parameter.  It should be one of the
+   PARAM_* constants defined in the gdb module.
+
+   If PARAM-TYPE is PARAM_ENUM, then ENUM-LIST is a list of strings that
+   are the valid values for this parameter.  The first value is the default.
+
+   SET-FUNC, if provided, is called after the parameter is set.
+   It is a function of one parameter: the <gdb:parameter> object.
+   It must return a string to be displayed to the user.
+   Setting a parameter is typically a silent operation, so typically ""
+   should be returned.
+
+   SHOW-FUNC, if provided, returns the string that is printed.
+   It is a function of two parameters: the <gdb:parameter> object
+   and the current value of the parameter as a string.
+
+   DOC, SET-DOC, SHOW-DOC are the doc strings for the parameter.
+
+   INITIAL-VALUE is the initial value of the parameter.
+
+   The result is the <gdb:parameter> Scheme object.
+   The parameter is not available to be used yet, however.
+   It must still be added to gdb with register-parameter!.  */
+
+static SCM
+gdbscm_make_parameter (SCM name_scm, SCM rest)
+{
+  const SCM keywords[] = {
+    command_class_keyword, parameter_type_keyword, enum_list_keyword,
+    set_func_keyword, show_func_keyword,
+    doc_keyword, set_doc_keyword, show_doc_keyword,
+    initial_value_keyword, SCM_BOOL_F
+  };
+  int cmd_class_arg_pos = -1, param_type_arg_pos = -1;
+  int enum_list_arg_pos = -1, set_func_arg_pos = -1, show_func_arg_pos = -1;
+  int doc_arg_pos = -1, set_doc_arg_pos = -1, show_doc_arg_pos = -1;
+  int initial_value_arg_pos = -1;
+  char *s;
+  char *name;
+  int cmd_class = no_class;
+  int param_type = var_boolean;
+  SCM enum_list_scm = SCM_BOOL_F;
+  SCM set_func = SCM_BOOL_F, show_func = SCM_BOOL_F;
+  char *doc = NULL, *set_doc = NULL, *show_doc = NULL;
+  SCM initial_value_scm = SCM_BOOL_F;
+  const char * const *enum_list = NULL;
+  SCM p_scm;
+  param_smob *p_smob;
+
+  gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, keywords, "s#iiOOOsssO",
+                             name_scm, &name, rest,
+                             &cmd_class_arg_pos, &cmd_class,
+                             &param_type_arg_pos, &param_type,
+                             &enum_list_arg_pos, &enum_list_scm,
+                             &set_func_arg_pos, &set_func,
+                             &show_func_arg_pos, &show_func,
+                             &doc_arg_pos, &doc,
+                             &set_doc_arg_pos, &set_doc,
+                             &show_doc_arg_pos, &show_doc,
+                             &initial_value_arg_pos, &initial_value_scm);
+
+  /* If doc is NULL, leave it NULL.  See add_setshow_cmd_full.  */
+  if (set_doc == NULL)
+    set_doc = get_doc_string ();
+  if (show_doc == NULL)
+    show_doc = get_doc_string ();
+
+  s = name;
+  name = gdbscm_canonicalize_command_name (s, 0);
+  xfree (s);
+  if (doc != NULL)
+    {
+      s = doc;
+      doc = gdbscm_gc_xstrdup (s);
+      xfree (s);
+    }
+  s = set_doc;
+  set_doc = gdbscm_gc_xstrdup (s);
+  xfree (s);
+  s = show_doc;
+  show_doc = gdbscm_gc_xstrdup (s);
+  xfree (s);
+
+  if (!gdbscm_valid_command_class_p (cmd_class))
+    {
+      gdbscm_out_of_range_error (FUNC_NAME, cmd_class_arg_pos,
+                                scm_from_int (cmd_class),
+                                _("invalid command class argument"));
+    }
+  if (!pascm_valid_parameter_type_p (param_type))
+    {
+      gdbscm_out_of_range_error (FUNC_NAME, param_type_arg_pos,
+                                scm_from_int (param_type),
+                                _("invalid parameter type argument"));
+    }
+  if (enum_list_arg_pos > 0 && param_type != var_enum)
+    {
+      gdbscm_misc_error (FUNC_NAME, enum_list_arg_pos, enum_list_scm,
+               _("#:enum-values can only be provided with PARAM_ENUM"));
+    }
+  if (enum_list_arg_pos < 0 && param_type == var_enum)
+    {
+      gdbscm_misc_error (FUNC_NAME, GDBSCM_ARG_NONE, SCM_BOOL_F,
+                        _("PARAM_ENUM requires an enum-values argument"));
+    }
+  if (set_func_arg_pos > 0)
+    {
+      SCM_ASSERT_TYPE (gdbscm_is_procedure (set_func), set_func,
+                      set_func_arg_pos, FUNC_NAME, _("procedure"));
+    }
+  if (show_func_arg_pos > 0)
+    {
+      SCM_ASSERT_TYPE (gdbscm_is_procedure (show_func), show_func,
+                      show_func_arg_pos, FUNC_NAME, _("procedure"));
+    }
+  if (param_type == var_enum)
+    {
+      /* Note: enum_list lives in GC space, so we don't have to worry about
+        freeing it if we later throw an exception.  */
+      enum_list = compute_enum_list (enum_list_scm, enum_list_arg_pos,
+                                    FUNC_NAME);
+    }
+
+  /* If initial-value is a function, we need the parameter object constructed
+     to pass it to the function.  A typical thing the function may want to do
+     is add an object-property to it to record the last known good value.  */
+  p_scm = pascm_make_param_smob ();
+  p_smob = (param_smob *) SCM_SMOB_DATA (p_scm);
+  /* These are all stored in GC space so that we don't have to worry about
+     freeing them if we throw an exception.  */
+  p_smob->name = name;
+  p_smob->cmd_class = cmd_class;
+  p_smob->type = (enum var_types) param_type;
+  p_smob->doc = doc;
+  p_smob->set_doc = set_doc;
+  p_smob->show_doc = show_doc;
+  p_smob->enumeration = enum_list;
+  p_smob->set_func = set_func;
+  p_smob->show_func = show_func;
+
+  if (initial_value_arg_pos > 0)
+    {
+      if (gdbscm_is_procedure (initial_value_scm))
+       {
+         initial_value_scm = gdbscm_safe_call_1 (initial_value_scm,
+                                                 p_smob->containing_scm, NULL);
+         if (gdbscm_is_exception (initial_value_scm))
+           gdbscm_throw (initial_value_scm);
+       }
+      pascm_set_param_value_x (param_type, &p_smob->value, enum_list,
+                              initial_value_scm,
+                              initial_value_arg_pos, FUNC_NAME);
+    }
+
+  return p_scm;
+}
+
+/* (register-parameter! <gdb:parameter>) -> unspecified
+
+   It is an error to register a parameter more than once.  */
+
+static SCM
+gdbscm_register_parameter_x (SCM self)
+{
+  param_smob *p_smob
+    = pascm_get_param_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+  char *cmd_name;
+  struct cmd_list_element **set_list, **show_list;
+  volatile struct gdb_exception except;
+
+  if (pascm_is_valid (p_smob))
+    scm_misc_error (FUNC_NAME, _("parameter is already registered"), SCM_EOL);
+
+  cmd_name = gdbscm_parse_command_name (p_smob->name, FUNC_NAME, SCM_ARG1,
+                                       &set_list, &setlist);
+  xfree (cmd_name);
+  cmd_name = gdbscm_parse_command_name (p_smob->name, FUNC_NAME, SCM_ARG1,
+                                       &show_list, &showlist);
+  p_smob->cmd_name = gdbscm_gc_xstrdup (cmd_name);
+  xfree (cmd_name);
+
+  TRY_CATCH (except, RETURN_MASK_ALL)
+    {
+      add_setshow_generic (p_smob->type, p_smob->cmd_class,
+                          p_smob->cmd_name, p_smob,
+                          p_smob->set_doc, p_smob->show_doc, p_smob->doc,
+                          (gdbscm_is_procedure (p_smob->set_func)
+                           ? pascm_set_func : NULL),
+                          (gdbscm_is_procedure (p_smob->show_func)
+                           ? pascm_show_func : NULL),
+                          set_list, show_list,
+                          &p_smob->set_command, &p_smob->show_command);
+    }
+  GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+  /* Note: At this point the parameter exists in gdb.
+     So no more errors after this point.  */
+
+  /* The owner of this parameter is not in GC-controlled memory, so we need
+     to protect it from GC until the parameter is deleted.  */
+  scm_gc_protect_object (p_smob->containing_scm);
+
+  return SCM_UNSPECIFIED;
+}
+
+/* (parameter-value <gdb:parameter>) -> value
+   (parameter-value <string>) -> value */
+
+static SCM
+gdbscm_parameter_value (SCM self)
+{
+  SCM_ASSERT_TYPE (pascm_is_parameter (self) || scm_is_string (self),
+                  self, SCM_ARG1, FUNC_NAME, _("<gdb:parameter> or string"));
+
+  if (pascm_is_parameter (self))
+    {
+      param_smob *p_smob = pascm_get_param_smob_arg_unsafe (self, SCM_ARG1,
+                                                           FUNC_NAME);
+
+      return pascm_param_value (p_smob->type, &p_smob->value,
+                               SCM_ARG1, FUNC_NAME);
+    }
+  else
+    {
+      char *name;
+      SCM except_scm;
+      struct cmd_list_element *alias, *prefix, *cmd;
+      const char *arg;
+      char *newarg;
+      int found = -1;
+      volatile struct gdb_exception except;
+
+      name = gdbscm_scm_to_host_string (self, NULL, &except_scm);
+      if (name == NULL)
+       gdbscm_throw (except_scm);
+      newarg = concat ("show ", name, (char *) NULL);
+      TRY_CATCH (except, RETURN_MASK_ALL)
+       {
+         found = lookup_cmd_composition (newarg, &alias, &prefix, &cmd);
+       }
+      xfree (name);
+      xfree (newarg);
+      GDBSCM_HANDLE_GDB_EXCEPTION (except);
+      if (!found)
+       {
+         gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, self,
+                                    _("parameter not found"));
+       }
+      if (cmd->var == NULL)
+       {
+         gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, self,
+                                    _("not a parameter"));
+       }
+
+      return pascm_param_value (cmd->var_type, cmd->var, SCM_ARG1, FUNC_NAME);
+    }
+}
+
+/* (set-parameter-value! <gdb:parameter> value) -> unspecified */
+
+static SCM
+gdbscm_set_parameter_value_x (SCM self, SCM value)
+{
+  param_smob *p_smob = pascm_get_param_smob_arg_unsafe (self, SCM_ARG1,
+                                                       FUNC_NAME);
+
+  pascm_set_param_value_x (p_smob->type, &p_smob->value, p_smob->enumeration,
+                          value, SCM_ARG2, FUNC_NAME);
+
+  return SCM_UNSPECIFIED;
+}
+\f
+/* Initialize the Scheme parameter support.  */
+
+static const scheme_function parameter_functions[] =
+{
+  { "make-parameter", 1, 0, 1, gdbscm_make_parameter,
+    "\
+Make a GDB parameter object.\n\
+\n\
+  Arguments: name\n\
+      [#:command-class <cmd-class>] [#:parameter-type <parameter-type>]\n\
+      [#:enum-list <enum-list>]\n\
+      [#:set-func function] [#:show-func function]\n\
+      [#:doc string] [#:set-doc string] [#:show-doc string]\n\
+      [#:initial-value initial-value]\n\
+    name: The name of the command.  It may consist of multiple words,\n\
+      in which case the final word is the name of the new parameter, and\n\
+      earlier words must be prefix commands.\n\
+    cmd-class: The class of the command, one of COMMAND_*.\n\
+      The default is COMMAND_NONE.\n\
+    parameter-type: The kind of parameter, one of PARAM_*\n\
+      The default is PARAM_BOOLEAN.\n\
+    enum-list: If parameter-type is PARAM_ENUM, then this specifies the set\n\
+      of values of the enum.\n\
+    set-func: A function of one parameter: the <gdb:parameter> object.\n\
+      Called *after* the parameter has been set.  Returns either \"\" or a\n\
+      non-empty string to be displayed to the user.\n\
+      If non-empty, GDB will add a trailing newline.\n\
+    show-func: A function of two parameters: the <gdb:parameter> object\n\
+      and the string representation of the current value.\n\
+      The result is a string to be displayed to the user.\n\
+      GDB will add a trailing newline.\n\
+    doc: The \"doc string\" of the parameter.\n\
+    set-doc: The \"doc string\" when setting the parameter.\n\
+    show-doc: The \"doc string\" when showing the parameter.\n\
+    initial-value: The initial value of the parameter." },
+
+  { "register-parameter!", 1, 0, 0, gdbscm_register_parameter_x,
+    "\
+Register a <gdb:parameter> object with GDB." },
+
+  { "parameter?", 1, 0, 0, gdbscm_parameter_p,
+    "\
+Return #t if the object is a <gdb:parameter> object." },
+
+  { "parameter-value", 1, 0, 0, gdbscm_parameter_value,
+    "\
+Return the value of a <gdb:parameter> object\n\
+or any gdb parameter if param is a string naming the parameter." },
+
+  { "set-parameter-value!", 2, 0, 0, gdbscm_set_parameter_value_x,
+    "\
+Set the value of a <gdb:parameter> object.\n\
+\n\
+  Arguments: <gdb:parameter> value" },
+
+  END_FUNCTIONS
+};
+
+void
+gdbscm_initialize_parameters (void)
+{
+  parameter_smob_tag
+    = gdbscm_make_smob_type (param_smob_name, sizeof (param_smob));
+  scm_set_smob_print (parameter_smob_tag, pascm_print_param_smob);
+
+  gdbscm_define_integer_constants (parameter_types, 1);
+  gdbscm_define_functions (parameter_functions, 1);
+
+  command_class_keyword = scm_from_latin1_keyword ("command-class");
+  parameter_type_keyword = scm_from_latin1_keyword ("parameter-type");
+  enum_list_keyword = scm_from_latin1_keyword ("enum-list");
+  set_func_keyword = scm_from_latin1_keyword ("set-func");
+  show_func_keyword = scm_from_latin1_keyword ("show-func");
+  doc_keyword = scm_from_latin1_keyword ("doc");
+  set_doc_keyword = scm_from_latin1_keyword ("set-doc");
+  show_doc_keyword = scm_from_latin1_keyword ("show-doc");
+  initial_value_keyword = scm_from_latin1_keyword ("initial-value");
+  auto_keyword = scm_from_latin1_keyword ("auto");
+  unlimited_keyword = scm_from_latin1_keyword ("unlimited");
+}
index c8d81c4..25f1d67 100644 (file)
@@ -90,10 +90,17 @@ gdbscm_call_scm_to_stringn (void *datap)
 
 /* Convert an SCM string to a string in charset CHARSET.
    This function is guaranteed to not throw an exception.
+
+   If LENP is NULL then the returned string is NUL-terminated,
+   and an exception is thrown if the string contains embedded NULs.
+   Otherwise the string is not guaranteed to be NUL-terminated, but worse
+   there's no space to put a NUL if we wanted to (scm_to_stringn limitation).
+
    If STRICT is non-zero, and there's a conversion error, then a
    <gdb:exception> object is stored in *EXCEPT_SCMP, and NULL is returned.
    If STRICT is zero, then escape sequences are used for characters that
    can't be converted, and EXCEPT_SCMP may be passed as NULL.
+
    Space for the result is allocated with malloc, caller must free.
    It is an error to call this if STRING is not a string.  */
 
@@ -151,6 +158,7 @@ gdbscm_call_scm_from_stringn (void *datap)
 
 /* Convert STRING to a Scheme string in charset CHARSET.
    This function is guaranteed to not throw an exception.
+
    If STRICT is non-zero, and there's a conversion error, then a
    <gdb:exception> object is returned.
    If STRICT is zero, then question marks are used for characters that
@@ -183,6 +191,36 @@ gdbscm_scm_from_string (const char *string, size_t len,
   return scm_result;
 }
 
+/* Convert an SCM string to a host string.
+   This function is guaranteed to not throw an exception.
+
+   If LENP is NULL then the returned string is NUL-terminated,
+   and if the string contains embedded NULs then NULL is returned with
+   an exception object stored in *EXCEPT_SCMP.
+   Otherwise the string is not guaranteed to be NUL-terminated, but worse
+   there's no space to put a NUL if we wanted to (scm_to_stringn limitation).
+
+   Returns NULL if there is a conversion error, with the exception object
+   stored in *EXCEPT_SCMP.
+   Space for the result is allocated with malloc, caller must free.
+   It is an error to call this if STRING is not a string.  */
+
+char *
+gdbscm_scm_to_host_string (SCM string, size_t *lenp, SCM *except_scmp)
+{
+  return gdbscm_scm_to_string (string, lenp, host_charset (), 1, except_scmp);
+}
+
+/* Convert a host string to an SCM string.
+   This function is guaranteed to not throw an exception.
+   Returns a <gdb:exception> object if there's a conversion error.  */
+
+SCM
+gdbscm_scm_from_host_string (const char *string, size_t len)
+{
+  return gdbscm_scm_from_string (string, len, host_charset (), 1);
+}
+
 /* (string->argv string) -> list
    Return list of strings split up according to GDB's argv parsing rules.
    This is useful when writing GDB commands in Scheme.  */
index 918a51b..6d9542d 100644 (file)
@@ -595,3 +595,32 @@ gdbscm_gc_xstrdup (const char *str)
   strcpy (result, str);
   return result;
 }
+
+/* Return a duplicate of ARGV living on the GC heap.  */
+
+const char * const *
+gdbscm_gc_dup_argv (char **argv)
+{
+  int i, len;
+  size_t string_space;
+  char *p, **result;
+
+  for (len = 0, string_space = 0; argv[len] != NULL; ++len)
+    string_space += strlen (argv[len]) + 1;
+
+  /* Allocating "pointerless" works because the pointers are all
+     self-contained within the object.  */
+  result = scm_gc_malloc_pointerless (((len + 1) * sizeof (char *))
+                                     + string_space, "parameter enum list");
+  p = (char *) &result[len + 1];
+
+  for (i = 0; i < len; ++i)
+    {
+      result[i] = p;
+      strcpy (p, argv[i]);
+      p += strlen (p) + 1;
+    }
+  result[i] = NULL;
+
+  return (const char * const *) result;
+}
index bec3ce4..9ded6eb 100644 (file)
@@ -1,5 +1,9 @@
 2014-06-02  Doug Evans  <xdje42@gmail.com>
 
+       * gdb.guile/scm-parameter.exp: New file.
+
+2014-06-02  Doug Evans  <xdje42@gmail.com>
+
        * gdb.guile/scm-cmd.c: New file.
        * gdb.guile/scm-cmd.exp: New file.
 
diff --git a/gdb/testsuite/gdb.guile/scm-parameter.exp b/gdb/testsuite/gdb.guile/scm-parameter.exp
new file mode 100644 (file)
index 0000000..0dd8a47
--- /dev/null
@@ -0,0 +1,168 @@
+# Copyright (C) 2010-2014 Free Software Foundation, Inc.
+
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+# This file is part of the GDB testsuite.
+# It tests GDB parameter support in Guile.
+
+load_lib gdb-guile.exp
+
+# Start with a fresh gdb.
+gdb_exit
+gdb_start
+gdb_reinitialize_dir $srcdir/$subdir
+
+# Skip all tests if Guile scripting is not enabled.
+if { [skip_guile_tests] } { continue }
+
+gdb_install_guile_utils
+gdb_install_guile_module
+
+# We use "." here instead of ":" so that this works on win32 too.
+gdb_test "guile (print (parameter-value \"directories\"))" "$srcdir/$subdir.\\\$cdir.\\\$cwd"
+
+# Test a simple boolean parameter, and parameter? while we're at it.
+
+gdb_test_multiline "Simple gdb boolean parameter" \
+    "guile" "" \
+    "(define test-param" "" \
+    "  (make-parameter \"print test-param\"" "" \
+    "   #:command-class COMMAND_DATA" "" \
+    "   #:parameter-type PARAM_BOOLEAN" "" \
+    "   #:doc \"When enabled, test param does something useful. When disabled, does nothing.\"" "" \
+    "   #:set-doc \"Set the state of the boolean test-param.\"" "" \
+    "   #:show-doc \"Show the state of the boolean test-param.\"" "" \
+    "   #:show-func (lambda (self value)" ""\
+    "      (format #f \"The state of the Test Parameter is ~a.\" value))" "" \
+    "   #:initial-value #t))" "" \
+    "(register-parameter! test-param)" "" \
+    "end"
+
+with_test_prefix "test-param" {
+    gdb_test "guile (print (parameter-value test-param))" "= #t" "parameter value (true)"
+    gdb_test "show print test-param" "The state of the Test Parameter is on." "Show parameter on"
+    gdb_test_no_output "set print test-param off"
+    gdb_test "show print test-param" "The state of the Test Parameter is off." "Show parameter off"
+    gdb_test "guile (print (parameter-value test-param))" "= #f" "parameter value (false)"
+    gdb_test "help show print test-param" "Show the state of the boolean test-param.*" "show help"
+    gdb_test "help set print test-param" "Set the state of the boolean test-param.*" "set help"
+    gdb_test "help set print" "set print test-param -- Set the state of the boolean test-param.*" "general help"
+
+    gdb_test "guile (print (parameter? test-param))" "= #t"
+    gdb_test "guile (print (parameter? 42))" "= #f"
+}
+
+# Test an enum parameter.
+
+gdb_test_multiline "enum gdb parameter" \
+    "guile" "" \
+    "(define test-enum-param" "" \
+    "  (make-parameter \"print test-enum-param\"" "" \
+    "   #:command-class COMMAND_DATA" "" \
+    "   #:parameter-type PARAM_ENUM" "" \
+    "   #:enum-list '(\"one\" \"two\")" "" \
+    "   #:doc \"When set, test param does something useful. When disabled, does nothing.\"" "" \
+    "   #:show-doc \"Show the state of the enum.\"" "" \
+    "   #:set-doc \"Set the state of the enum.\"" "" \
+    "   #:show-func (lambda (self value)" "" \
+    "      (format #f \"The state of the enum is ~a.\" value))" "" \
+    "   #:initial-value \"one\"))" "" \
+    "(register-parameter! test-enum-param)" "" \
+    "end"
+
+with_test_prefix "test-enum-param" {
+    gdb_test "guile (print (parameter-value test-enum-param))" "one" "enum parameter value (one)"
+    gdb_test "show print test-enum-param" "The state of the enum is one." "show initial value"
+    gdb_test_no_output "set print test-enum-param two"
+    gdb_test "show print test-enum-param" "The state of the enum is two." "show new value"
+    gdb_test "guile (print (parameter-value test-enum-param))" "two" "enum parameter value (two)"
+    gdb_test "set print test-enum-param three" "Undefined item: \"three\".*" "set invalid enum parameter" 
+}
+
+# Test a file parameter.
+
+gdb_test_multiline "file gdb parameter" \
+    "guile" "" \
+    "(define test-file-param" "" \
+    "  (make-parameter \"test-file-param\"" "" \
+    "   #:command-class COMMAND_FILES" "" \
+    "   #:parameter-type PARAM_FILENAME" "" \
+    "   #:doc \"When set, test param does something useful. When disabled, does nothing.\"" "" \
+    "   #:show-doc \"Show the name of the file.\"" "" \
+    "   #:set-doc \"Set the name of the file.\"" "" \
+    "   #:show-func (lambda (self value)" "" \
+    "      (format #f \"The name of the file is ~a.\" value))" "" \
+    "   #:initial-value \"foo.txt\"))" "" \
+    "(register-parameter! test-file-param)" "" \
+    "end"
+
+with_test_prefix "test-file-param" {
+    gdb_test "guile (print (parameter-value test-file-param))" "foo.txt" "initial parameter value"
+    gdb_test "show test-file-param" "The name of the file is foo.txt." "show initial value"
+    gdb_test_no_output "set test-file-param bar.txt"
+    gdb_test "show test-file-param" "The name of the file is bar.txt." "show new value"
+    gdb_test "guile (print (parameter-value test-file-param))" "bar.txt" " new parameter value"
+    gdb_test "set test-file-param" "Argument required.*" 
+}
+
+# Test a parameter that is not documented.
+
+gdb_test_multiline "undocumented gdb parameter" \
+    "guile" "" \
+    "(register-parameter! (make-parameter \"print test-undoc-param\"" "" \
+    "   #:command-class COMMAND_DATA" "" \
+    "   #:parameter-type PARAM_BOOLEAN" "" \
+    "   #:show-func (lambda (self value)" "" \
+    "      (format #f \"The state of the Test Parameter is ~a.\" value))" "" \
+    "   #:initial-value #t))" "" \
+    "end"
+
+with_test_prefix "test-undocumented-param" {
+    gdb_test "show print test-undoc-param" "The state of the Test Parameter is on." "show parameter on"
+    gdb_test_no_output "set print test-undoc-param off"
+    gdb_test "show print test-undoc-param" "The state of the Test Parameter is off." "show parameter off"
+    gdb_test "help show print test-undoc-param" "This command is not documented." "show help"
+    gdb_test "help set print test-undoc-param" "This command is not documented." "set help"
+    gdb_test "help set print" "set print test-undoc-param -- This command is not documented.*" "general help"
+}
+
+# Test a parameter with a restricted range, where we need to notify the user
+# and restore the previous value.
+
+gdb_test_multiline "restricted gdb parameter" \
+    "guile" "" \
+    "(register-parameter! (make-parameter \"test-restricted-param\"" "" \
+    "   #:command-class COMMAND_DATA" "" \
+    "   #:parameter-type PARAM_ZINTEGER" "" \
+    "   #:set-func (lambda (self)" "" \
+    "      (let ((value (parameter-value self)))" "" \
+    "        (if (and (>= value 0) (<= value 10))" "" \
+    "            \"\"" "" \
+    "            (begin" "" \
+    "              (set-parameter-value! self (object-property self 'value))" "" \
+    "              \"Error: Range of parameter is 0-10.\"))))" "" \
+    "   #:show-func (lambda (self value)" "" \
+    "      (format #f \"The value of the restricted parameter is ~a.\" value))" "" \
+    "   #:initial-value (lambda (self)" "" \
+    "      (set-object-property! self 'value 2)" "" \
+    "      2)))" "" \
+    "end"
+
+with_test_prefix "test-restricted-param" {
+    gdb_test "show test-restricted-param" "The value of the restricted parameter is 2."
+    gdb_test_no_output "set test-restricted-param 10"
+    gdb_test "show test-restricted-param" "The value of the restricted parameter is 10."
+    gdb_test "set test-restricted-param 42" "Error: Range of parameter is 0-10."
+    gdb_test "show test-restricted-param" "The value of the restricted parameter is 2."
+}