gdb/guile/scm-cmd.c

   1 /* GDB commands implemented in Scheme.
   2
   3    Copyright (C) 2008-2017 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 /* See README file in this directory for implementation notes, coding
  21    conventions, et.al.  */
  22
  23 #include "defs.h"
  24 #include <ctype.h>
  25 #include "charset.h"
  26 #include "gdbcmd.h"
  27 #include "cli/cli-decode.h"
  28 #include "completer.h"
  29 #include "guile-internal.h"
  30
  31 /* The <gdb:command> smob.
  32
  33    Note: Commands are added to gdb using a two step process:
  34    1) Call make-command to create a <gdb:command> object.
  35    2) Call register-command! to add the command to gdb.
  36    It is done this way so that the constructor, make-command, doesn't have
  37    any side-effects.  This means that the smob needs to store everything
  38    that was passed to make-command.  */
  39
  40 typedef struct _command_smob
  41 {
  42   /* This always appears first.  */
  43   gdb_smob base;
  44
  45   /* The name of the command, as passed to make-command.  */
  46   char *name;
  47
  48   /* The last word of the command.
  49      This is needed because add_cmd requires us to allocate space
  50      for it. :-(  */
  51   char *cmd_name;
  52
  53   /* Non-zero if this is a prefix command.  */
  54   int is_prefix;
  55
  56   /* One of the COMMAND_* constants.  */
  57   enum command_class cmd_class;
  58
  59   /* The documentation for the command.  */
  60   char *doc;
  61
  62   /* The corresponding gdb command object.
  63      This is NULL if the command has not been registered yet, or
  64      is no longer registered.  */
  65   struct cmd_list_element *command;
  66
  67   /* A prefix command requires storage for a list of its sub-commands.
  68      A pointer to this is passed to add_prefix_command, and to add_cmd
  69      for sub-commands of that prefix.
  70      This is NULL if the command has not been registered yet, or
  71      is no longer registered.  If this command is not a prefix
  72      command, then this field is unused.  */
  73   struct cmd_list_element *sub_list;
  74
  75   /* The procedure to call to invoke the command.
  76      (lambda (self arg from-tty) ...).
  77      Its result is unspecified.  */
  78   SCM invoke;
  79
  80   /* Either #f, one of the COMPLETE_* constants, or a procedure to call to
  81      perform command completion.  Called as (lambda (self text word) ...).  */
  82   SCM complete;
  83
  84   /* The <gdb:command> object we are contained in, needed to protect/unprotect
  85      the object since a reference to it comes from non-gc-managed space
  86      (the command context pointer).  */
  87   SCM containing_scm;
  88 } command_smob;
  89
  90 static const char command_smob_name[] = "gdb:command";
  91
  92 /* The tag Guile knows the objfile smob by.  */
  93 static scm_t_bits command_smob_tag;
  94
  95 /* Keywords used by make-command.  */
  96 static SCM invoke_keyword;
  97 static SCM command_class_keyword;
  98 static SCM completer_class_keyword;
  99 static SCM prefix_p_keyword;
 100 static SCM doc_keyword;
 101
 102 /* Struct representing built-in completion types.  */
 103 struct cmdscm_completer
 104 {
 105   /* Scheme symbol name.  */
 106   const char *name;
 107   /* Completion function.  */
 108   completer_ftype *completer;
 109 };
 110
 111 static const struct cmdscm_completer cmdscm_completers[] =
 112 {
 113   { "COMPLETE_NONE", noop_completer },
 114   { "COMPLETE_FILENAME", filename_completer },
 115   { "COMPLETE_LOCATION", location_completer },
 116   { "COMPLETE_COMMAND", command_completer },
 117   { "COMPLETE_SYMBOL", make_symbol_completion_list_fn },
 118   { "COMPLETE_EXPRESSION", expression_completer },
 119 };
 120
 121 #define N_COMPLETERS (sizeof (cmdscm_completers) \
 122                       / sizeof (cmdscm_completers[0]))
 123
 124 static int cmdscm_is_valid (command_smob *);
 125 \f
 126 /* Administrivia for command smobs.  */
 127
 128 /* The smob "print" function for <gdb:command>.  */
 129
 130 static int
 131 cmdscm_print_command_smob (SCM self, SCM port, scm_print_state *pstate)
 132 {
 133   command_smob *c_smob = (command_smob *) SCM_SMOB_DATA (self);
 134
 135   gdbscm_printf (port, "#<%s", command_smob_name);
 136
 137   gdbscm_printf (port, " %s",
 138                  c_smob->name != NULL ? c_smob->name : "{unnamed}");
 139
 140   if (! cmdscm_is_valid (c_smob))
 141     scm_puts (" {invalid}", port);
 142
 143   scm_puts (">", port);
 144
 145   scm_remember_upto_here_1 (self);
 146
 147   /* Non-zero means success.  */
 148   return 1;
 149 }
 150
 151 /* Low level routine to create a <gdb:command> object.
 152    It's empty in the sense that a command still needs to be associated
 153    with it.  */
 154
 155 static SCM
 156 cmdscm_make_command_smob (void)
 157 {
 158   command_smob *c_smob = (command_smob *)
 159     scm_gc_malloc (sizeof (command_smob), command_smob_name);
 160   SCM c_scm;
 161
 162   memset (c_smob, 0, sizeof (*c_smob));
 163   c_smob->cmd_class = no_class;
 164   c_smob->invoke = SCM_BOOL_F;
 165   c_smob->complete = SCM_BOOL_F;
 166   c_scm = scm_new_smob (command_smob_tag, (scm_t_bits) c_smob);
 167   c_smob->containing_scm = c_scm;
 168   gdbscm_init_gsmob (&c_smob->base);
 169
 170   return c_scm;
 171 }
 172
 173 /* Clear the COMMAND pointer in C_SMOB and unprotect the object from GC.  */
 174
 175 static void
 176 cmdscm_release_command (command_smob *c_smob)
 177 {
 178   c_smob->command = NULL;
 179   scm_gc_unprotect_object (c_smob->containing_scm);
 180 }
 181
 182 /* Return non-zero if SCM is a command smob.  */
 183
 184 static int
 185 cmdscm_is_command (SCM scm)
 186 {
 187   return SCM_SMOB_PREDICATE (command_smob_tag, scm);
 188 }
 189
 190 /* (command? scm) -> boolean */
 191
 192 static SCM
 193 gdbscm_command_p (SCM scm)
 194 {
 195   return scm_from_bool (cmdscm_is_command (scm));
 196 }
 197
 198 /* Returns the <gdb:command> object in SELF.
 199    Throws an exception if SELF is not a <gdb:command> object.  */
 200
 201 static SCM
 202 cmdscm_get_command_arg_unsafe (SCM self, int arg_pos, const char *func_name)
 203 {
 204   SCM_ASSERT_TYPE (cmdscm_is_command (self), self, arg_pos, func_name,
 205                    command_smob_name);
 206
 207   return self;
 208 }
 209
 210 /* Returns a pointer to the command smob of SELF.
 211    Throws an exception if SELF is not a <gdb:command> object.  */
 212
 213 static command_smob *
 214 cmdscm_get_command_smob_arg_unsafe (SCM self, int arg_pos,
 215                                     const char *func_name)
 216 {
 217   SCM c_scm = cmdscm_get_command_arg_unsafe (self, arg_pos, func_name);
 218   command_smob *c_smob = (command_smob *) SCM_SMOB_DATA (c_scm);
 219
 220   return c_smob;
 221 }
 222
 223 /* Return non-zero if command C_SMOB is valid.  */
 224
 225 static int
 226 cmdscm_is_valid (command_smob *c_smob)
 227 {
 228   return c_smob->command != NULL;
 229 }
 230
 231 /* Returns a pointer to the command smob of SELF.
 232    Throws an exception if SELF is not a valid <gdb:command> object.  */
 233
 234 static command_smob *
 235 cmdscm_get_valid_command_smob_arg_unsafe (SCM self, int arg_pos,
 236                                           const char *func_name)
 237 {
 238   command_smob *c_smob
 239     = cmdscm_get_command_smob_arg_unsafe (self, arg_pos, func_name);
 240
 241   if (!cmdscm_is_valid (c_smob))
 242     {
 243       gdbscm_invalid_object_error (func_name, arg_pos, self,
 244                                    _("<gdb:command>"));
 245     }
 246
 247   return c_smob;
 248 }
 249 \f
 250 /* Scheme functions for GDB commands.  */
 251
 252 /* (command-valid? <gdb:command>) -> boolean
 253    Returns #t if SELF is still valid.  */
 254
 255 static SCM
 256 gdbscm_command_valid_p (SCM self)
 257 {
 258   command_smob *c_smob
 259     = cmdscm_get_command_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 260
 261   return scm_from_bool (cmdscm_is_valid (c_smob));
 262 }
 263
 264 /* (dont-repeat cmd) -> unspecified
 265    Scheme function which wraps dont_repeat.  */
 266
 267 static SCM
 268 gdbscm_dont_repeat (SCM self)
 269 {
 270   /* We currently don't need anything from SELF, but still verify it.  */
 271   command_smob *c_smob
 272     = cmdscm_get_valid_command_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 273
 274   dont_repeat ();
 275
 276   return SCM_UNSPECIFIED;
 277 }
 278 \f
 279 /* The make-command function.  */
 280
 281 /* Called if the gdb cmd_list_element is destroyed.  */
 282
 283 static void
 284 cmdscm_destroyer (struct cmd_list_element *self, void *context)
 285 {
 286   command_smob *c_smob = (command_smob *) context;
 287
 288   cmdscm_release_command (c_smob);
 289 }
 290
 291 /* Called by gdb to invoke the command.  */
 292
 293 static void
 294 cmdscm_function (struct cmd_list_element *command, char *args, int from_tty)
 295 {
 296   command_smob *c_smob/*obj*/ = (command_smob *) get_cmd_context (command);
 297   SCM arg_scm, tty_scm, result;
 298
 299   gdb_assert (c_smob != NULL);
 300
 301   if (args == NULL)
 302     args = "";
 303   arg_scm = gdbscm_scm_from_string (args, strlen (args), host_charset (), 1);
 304   if (gdbscm_is_exception (arg_scm))
 305     error (_("Could not convert arguments to Scheme string."));
 306
 307   tty_scm = scm_from_bool (from_tty);
 308
 309   result = gdbscm_safe_call_3 (c_smob->invoke, c_smob->containing_scm,
 310                                arg_scm, tty_scm, gdbscm_user_error_p);
 311
 312   if (gdbscm_is_exception (result))
 313     {
 314       /* Don't print the stack if this was an error signalled by the command
 315          itself.  */
 316       if (gdbscm_user_error_p (gdbscm_exception_key (result)))
 317         {
 318           char *msg = gdbscm_exception_message_to_string (result);
 319
 320           make_cleanup (xfree, msg);
 321           error ("%s", msg);
 322         }
 323       else
 324         {
 325           gdbscm_print_gdb_exception (SCM_BOOL_F, result);
 326           error (_("Error occurred in Scheme-implemented GDB command."));
 327         }
 328     }
 329 }
 330
 331 /* Subroutine of cmdscm_completer to simplify it.
 332    Print an error message indicating that COMPLETION is a bad completion
 333    result.  */
 334
 335 static void
 336 cmdscm_bad_completion_result (const char *msg, SCM completion)
 337 {
 338   SCM port = scm_current_error_port ();
 339
 340   scm_puts (msg, port);
 341   scm_display (completion, port);
 342   scm_newline (port);
 343 }
 344
 345 /* Subroutine of cmdscm_completer to simplify it.
 346    Validate COMPLETION and add to RESULT.
 347    If an error occurs print an error message.
 348    The result is a boolean indicating success.  */
 349
 350 static int
 351 cmdscm_add_completion (SCM completion, VEC (char_ptr) **result)
 352 {
 353   char *item;
 354   SCM except_scm;
 355
 356   if (!scm_is_string (completion))
 357     {
 358       /* Inform the user, but otherwise ignore the entire result.  */
 359       cmdscm_bad_completion_result (_("Bad text from completer: "),
 360                                     completion);
 361       return 0;
 362     }
 363
 364   item = gdbscm_scm_to_string (completion, NULL, host_charset (), 1,
 365                                &except_scm);
 366   if (item == NULL)
 367     {
 368       /* Inform the user, but otherwise ignore the entire result.  */
 369       gdbscm_print_gdb_exception (SCM_BOOL_F, except_scm);
 370       return 0;
 371     }
 372
 373   VEC_safe_push (char_ptr, *result, item);
 374
 375   return 1;
 376 }
 377
 378 /* Called by gdb for command completion.  */
 379
 380 static VEC (char_ptr) *
 381 cmdscm_completer (struct cmd_list_element *command,
 382                   const char *text, const char *word)
 383 {
 384   command_smob *c_smob/*obj*/ = (command_smob *) get_cmd_context (command);
 385   SCM completer_result_scm;
 386   SCM text_scm, word_scm, result_scm;
 387   VEC (char_ptr) *result = NULL;
 388
 389   gdb_assert (c_smob != NULL);
 390   gdb_assert (gdbscm_is_procedure (c_smob->complete));
 391
 392   text_scm = gdbscm_scm_from_string (text, strlen (text), host_charset (),
 393                                      1);
 394   if (gdbscm_is_exception (text_scm))
 395     error (_("Could not convert \"text\" argument to Scheme string."));
 396   word_scm = gdbscm_scm_from_string (word, strlen (word), host_charset (),
 397                                      1);
 398   if (gdbscm_is_exception (word_scm))
 399     error (_("Could not convert \"word\" argument to Scheme string."));
 400
 401   completer_result_scm
 402     = gdbscm_safe_call_3 (c_smob->complete, c_smob->containing_scm,
 403                           text_scm, word_scm, NULL);
 404
 405   if (gdbscm_is_exception (completer_result_scm))
 406     {
 407       /* Inform the user, but otherwise ignore.  */
 408       gdbscm_print_gdb_exception (SCM_BOOL_F, completer_result_scm);
 409       goto done;
 410     }
 411
 412   if (gdbscm_is_true (scm_list_p (completer_result_scm)))
 413     {
 414       SCM list = completer_result_scm;
 415
 416       while (!scm_is_eq (list, SCM_EOL))
 417         {
 418           SCM next = scm_car (list);
 419
 420           if (!cmdscm_add_completion (next, &result))
 421             {
 422               VEC_free (char_ptr, result);
 423               goto done;
 424             }
 425
 426           list = scm_cdr (list);
 427         }
 428     }
 429   else if (itscm_is_iterator (completer_result_scm))
 430     {
 431       SCM iter = completer_result_scm;
 432       SCM next = itscm_safe_call_next_x (iter, NULL);
 433
 434       while (gdbscm_is_true (next))
 435         {
 436           if (gdbscm_is_exception (next))
 437             {
 438               /* Inform the user, but otherwise ignore the entire result.  */
 439               gdbscm_print_gdb_exception (SCM_BOOL_F, completer_result_scm);
 440               VEC_free (char_ptr, result);
 441               goto done;
 442             }
 443
 444           if (!cmdscm_add_completion (next, &result))
 445             {
 446               VEC_free (char_ptr, result);
 447               goto done;
 448             }
 449
 450           next = itscm_safe_call_next_x (iter, NULL);
 451         }
 452     }
 453   else
 454     {
 455       /* Inform the user, but otherwise ignore.  */
 456       cmdscm_bad_completion_result (_("Bad completer result: "),
 457                                     completer_result_scm);
 458     }
 459
 460  done:
 461   return result;
 462 }
 463
 464 /* Helper for gdbscm_make_command which locates the command list to use and
 465    pulls out the command name.
 466
 467    NAME is the command name list.  The final word in the list is the
 468    name of the new command.  All earlier words must be existing prefix
 469    commands.
 470
 471    *BASE_LIST is set to the final prefix command's list of
 472    *sub-commands.
 473
 474    START_LIST is the list in which the search starts.
 475
 476    This function returns the xmalloc()d name of the new command.
 477    On error a Scheme exception is thrown.  */
 478
 479 char *
 480 gdbscm_parse_command_name (const char *name,
 481                            const char *func_name, int arg_pos,
 482                            struct cmd_list_element ***base_list,
 483                            struct cmd_list_element **start_list)
 484 {
 485   struct cmd_list_element *elt;
 486   int len = strlen (name);
 487   int i, lastchar;
 488   char *prefix_text;
 489   const char *prefix_text2;
 490   char *result, *msg;
 491
 492   /* Skip trailing whitespace.  */
 493   for (i = len - 1; i >= 0 && (name[i] == ' ' || name[i] == '\t'); --i)
 494     ;
 495   if (i < 0)
 496     {
 497       gdbscm_out_of_range_error (func_name, arg_pos,
 498                                  gdbscm_scm_from_c_string (name),
 499                                  _("no command name found"));
 500     }
 501   lastchar = i;
 502
 503   /* Find first character of the final word.  */
 504   for (; i > 0 && (isalnum (name[i - 1])
 505                    || name[i - 1] == '-'
 506                    || name[i - 1] == '_');
 507        --i)
 508     ;
 509   result = (char *) xmalloc (lastchar - i + 2);
 510   memcpy (result, &name[i], lastchar - i + 1);
 511   result[lastchar - i + 1] = '\0';
 512
 513   /* Skip whitespace again.  */
 514   for (--i; i >= 0 && (name[i] == ' ' || name[i] == '\t'); --i)
 515     ;
 516   if (i < 0)
 517     {
 518       *base_list = start_list;
 519       return result;
 520     }
 521
 522   prefix_text = (char *) xmalloc (i + 2);
 523   memcpy (prefix_text, name, i + 1);
 524   prefix_text[i + 1] = '\0';
 525
 526   prefix_text2 = prefix_text;
 527   elt = lookup_cmd_1 (&prefix_text2, *start_list, NULL, 1);
 528   if (elt == NULL || elt == CMD_LIST_AMBIGUOUS)
 529     {
 530       msg = xstrprintf (_("could not find command prefix '%s'"), prefix_text);
 531       xfree (prefix_text);
 532       xfree (result);
 533       scm_dynwind_begin ((scm_t_dynwind_flags) 0);
 534       gdbscm_dynwind_xfree (msg);
 535       gdbscm_out_of_range_error (func_name, arg_pos,
 536                                  gdbscm_scm_from_c_string (name), msg);
 537     }
 538
 539   if (elt->prefixlist)
 540     {
 541       xfree (prefix_text);
 542       *base_list = elt->prefixlist;
 543       return result;
 544     }
 545
 546   msg = xstrprintf (_("'%s' is not a prefix command"), prefix_text);
 547   xfree (prefix_text);
 548   xfree (result);
 549   scm_dynwind_begin ((scm_t_dynwind_flags) 0);
 550   gdbscm_dynwind_xfree (msg);
 551   gdbscm_out_of_range_error (func_name, arg_pos,
 552                              gdbscm_scm_from_c_string (name), msg);
 553   /* NOTREACHED */
 554 }
 555
 556 static const scheme_integer_constant command_classes[] =
 557 {
 558   /* Note: alias and user are special; pseudo appears to be unused,
 559      and there is no reason to expose tui, I think.  */
 560   { "COMMAND_NONE", no_class },
 561   { "COMMAND_RUNNING", class_run },
 562   { "COMMAND_DATA", class_vars },
 563   { "COMMAND_STACK", class_stack },
 564   { "COMMAND_FILES", class_files },
 565   { "COMMAND_SUPPORT", class_support },
 566   { "COMMAND_STATUS", class_info },
 567   { "COMMAND_BREAKPOINTS", class_breakpoint },
 568   { "COMMAND_TRACEPOINTS", class_trace },
 569   { "COMMAND_OBSCURE", class_obscure },
 570   { "COMMAND_MAINTENANCE", class_maintenance },
 571   { "COMMAND_USER", class_user },
 572
 573   END_INTEGER_CONSTANTS
 574 };
 575
 576 /* Return non-zero if command_class is a valid command class.  */
 577
 578 int
 579 gdbscm_valid_command_class_p (int command_class)
 580 {
 581   int i;
 582
 583   for (i = 0; command_classes[i].name != NULL; ++i)
 584     {
 585       if (command_classes[i].value == command_class)
 586         return 1;
 587     }
 588
 589   return 0;
 590 }
 591
 592 /* Return a normalized form of command NAME.
 593    That is tabs are replaced with spaces and multiple spaces are replaced
 594    with a single space.
 595    If WANT_TRAILING_SPACE is non-zero, add one space at the end.  This is for
 596    prefix commands.
 597    but that is the caller's responsibility.
 598    Space for the result is allocated on the GC heap.  */
 599
 600 char *
 601 gdbscm_canonicalize_command_name (const char *name, int want_trailing_space)
 602 {
 603   int i, out, seen_word;
 604   char *result
 605     = (char *) scm_gc_malloc_pointerless (strlen (name) + 2, FUNC_NAME);
 606
 607   i = out = seen_word = 0;
 608   while (name[i])
 609     {
 610       /* Skip whitespace.  */
 611       while (name[i] == ' ' || name[i] == '\t')
 612         ++i;
 613       /* Copy non-whitespace characters.  */
 614       if (name[i])
 615         {
 616           if (seen_word)
 617             result[out++] = ' ';
 618           while (name[i] && name[i] != ' ' && name[i] != '\t')
 619             result[out++] = name[i++];
 620           seen_word = 1;
 621         }
 622     }
 623   if (want_trailing_space)
 624     result[out++] = ' ';
 625   result[out] = '\0';
 626
 627   return result;
 628 }
 629
 630 /* (make-command name [#:invoke lambda]
 631      [#:command-class class] [#:completer-class completer]
 632      [#:prefix? <bool>] [#:doc <string>]) -> <gdb:command>
 633
 634    NAME is the name of the command.  It may consist of multiple words,
 635    in which case the final word is the name of the new command, and
 636    earlier words must be prefix commands.
 637
 638    INVOKE is a procedure of three arguments that performs the command when
 639    invoked: (lambda (self arg from-tty) ...).
 640    Its result is unspecified.
 641
 642    CLASS is the kind of command.  It must be one of the COMMAND_*
 643    constants defined in the gdb module.  If not specified, "no_class" is used.
 644
 645    COMPLETER is the kind of completer.  It must be either:
 646      #f - completion is not supported for this command.
 647      One of the COMPLETE_* constants defined in the gdb module.
 648      A procedure of three arguments: (lambda (self text word) ...).
 649        Its result is one of:
 650          A list of strings.
 651          A <gdb:iterator> object that returns the set of possible completions,
 652          ending with #f.
 653          TODO(dje): Once PR 16699 is fixed, add support for returning
 654          a COMPLETE_* constant.
 655    If not specified, then completion is not supported for this command.
 656
 657    If PREFIX is #t, then this command is a prefix command.
 658
 659    DOC is the doc string for the command.
 660
 661    The result is the <gdb:command> Scheme object.
 662    The command is not available to be used yet, however.
 663    It must still be added to gdb with register-command!.  */
 664
 665 static SCM
 666 gdbscm_make_command (SCM name_scm, SCM rest)
 667 {
 668   const SCM keywords[] = {
 669     invoke_keyword, command_class_keyword, completer_class_keyword,
 670     prefix_p_keyword, doc_keyword, SCM_BOOL_F
 671   };
 672   int invoke_arg_pos = -1, command_class_arg_pos = 1;
 673   int completer_class_arg_pos = -1, is_prefix_arg_pos = -1;
 674   int doc_arg_pos = -1;
 675   char *s;
 676   char *name;
 677   enum command_class command_class = no_class;
 678   SCM completer_class = SCM_BOOL_F;
 679   int is_prefix = 0;
 680   char *doc = NULL;
 681   SCM invoke = SCM_BOOL_F;
 682   SCM c_scm;
 683   command_smob *c_smob;
 684
 685   gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, keywords, "s#OiOts",
 686                               name_scm, &name, rest,
 687                               &invoke_arg_pos, &invoke,
 688                               &command_class_arg_pos, &command_class,
 689                               &completer_class_arg_pos, &completer_class,
 690                               &is_prefix_arg_pos, &is_prefix,
 691                               &doc_arg_pos, &doc);
 692
 693   if (doc == NULL)
 694     doc = xstrdup (_("This command is not documented."));
 695
 696   s = name;
 697   name = gdbscm_canonicalize_command_name (s, is_prefix);
 698   xfree (s);
 699   s = doc;
 700   doc = gdbscm_gc_xstrdup (s);
 701   xfree (s);
 702
 703   if (is_prefix
 704       ? name[0] == ' '
 705       : name[0] == '\0')
 706     {
 707       gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, name_scm,
 708                                  _("no command name found"));
 709     }
 710
 711   if (gdbscm_is_true (invoke))
 712     {
 713       SCM_ASSERT_TYPE (gdbscm_is_procedure (invoke), invoke,
 714                        invoke_arg_pos, FUNC_NAME, _("procedure"));
 715     }
 716
 717   if (!gdbscm_valid_command_class_p (command_class))
 718     {
 719       gdbscm_out_of_range_error (FUNC_NAME, command_class_arg_pos,
 720                                  scm_from_int (command_class),
 721                                  _("invalid command class argument"));
 722     }
 723
 724   SCM_ASSERT_TYPE (gdbscm_is_false (completer_class)
 725                    || scm_is_integer (completer_class)
 726                    || gdbscm_is_procedure (completer_class),
 727                    completer_class, completer_class_arg_pos, FUNC_NAME,
 728                    _("integer or procedure"));
 729   if (scm_is_integer (completer_class)
 730       && !scm_is_signed_integer (completer_class, 0, N_COMPLETERS - 1))
 731     {
 732       gdbscm_out_of_range_error (FUNC_NAME, completer_class_arg_pos,
 733                                  completer_class,
 734                                  _("invalid completion type argument"));
 735     }
 736
 737   c_scm = cmdscm_make_command_smob ();
 738   c_smob = (command_smob *) SCM_SMOB_DATA (c_scm);
 739   c_smob->name = name;
 740   c_smob->is_prefix = is_prefix;
 741   c_smob->cmd_class = command_class;
 742   c_smob->doc = doc;
 743   c_smob->invoke = invoke;
 744   c_smob->complete = completer_class;
 745
 746   return c_scm;
 747 }
 748
 749 /* (register-command! <gdb:command>) -> unspecified
 750
 751    It is an error to register a command more than once.  */
 752
 753 static SCM
 754 gdbscm_register_command_x (SCM self)
 755 {
 756   command_smob *c_smob
 757     = cmdscm_get_command_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 758   char *cmd_name, *pfx_name;
 759   struct cmd_list_element **cmd_list;
 760   struct cmd_list_element *cmd = NULL;
 761
 762   if (cmdscm_is_valid (c_smob))
 763     scm_misc_error (FUNC_NAME, _("command is already registered"), SCM_EOL);
 764
 765   cmd_name = gdbscm_parse_command_name (c_smob->name, FUNC_NAME, SCM_ARG1,
 766                                         &cmd_list, &cmdlist);
 767   c_smob->cmd_name = gdbscm_gc_xstrdup (cmd_name);
 768   xfree (cmd_name);
 769
 770   TRY
 771     {
 772       if (c_smob->is_prefix)
 773         {
 774           /* If we have our own "invoke" method, then allow unknown
 775              sub-commands.  */
 776           int allow_unknown = gdbscm_is_true (c_smob->invoke);
 777
 778           cmd = add_prefix_cmd (c_smob->cmd_name, c_smob->cmd_class,
 779                                 NULL, c_smob->doc, &c_smob->sub_list,
 780                                 c_smob->name, allow_unknown, cmd_list);
 781         }
 782       else
 783         {
 784           cmd = add_cmd (c_smob->cmd_name, c_smob->cmd_class,
 785                          NULL, c_smob->doc, cmd_list);
 786         }
 787     }
 788   CATCH (except, RETURN_MASK_ALL)
 789     {
 790       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 791     }
 792   END_CATCH
 793
 794   /* Note: At this point the command exists in gdb.
 795      So no more errors after this point.  */
 796
 797   /* There appears to be no API to set this.  */
 798   cmd->func = cmdscm_function;
 799   cmd->destroyer = cmdscm_destroyer;
 800
 801   c_smob->command = cmd;
 802   set_cmd_context (cmd, c_smob);
 803
 804   if (gdbscm_is_true (c_smob->complete))
 805     {
 806       set_cmd_completer (cmd,
 807                          scm_is_integer (c_smob->complete)
 808                          ? cmdscm_completers[scm_to_int (c_smob->complete)].completer
 809                          : cmdscm_completer);
 810     }
 811
 812   /* The owner of this command is not in GC-controlled memory, so we need
 813      to protect it from GC until the command is deleted.  */
 814   scm_gc_protect_object (c_smob->containing_scm);
 815
 816   return SCM_UNSPECIFIED;
 817 }
 818 \f
 819 /* Initialize the Scheme command support.  */
 820
 821 static const scheme_function command_functions[] =
 822 {
 823   { "make-command", 1, 0, 1, as_a_scm_t_subr (gdbscm_make_command),
 824     "\
 825 Make a GDB command object.\n\
 826 \n\
 827   Arguments: name [#:invoke lambda]\n\
 828       [#:command-class <class>] [#:completer-class <completer>]\n\
 829       [#:prefix? <bool>] [#:doc string]\n\
 830     name: The name of the command.  It may consist of multiple words,\n\
 831       in which case the final word is the name of the new command, and\n\
 832       earlier words must be prefix commands.\n\
 833     invoke: A procedure of three arguments to perform the command.\n\
 834       (lambda (self arg from-tty) ...)\n\
 835       Its result is unspecified.\n\
 836     class: The class of the command, one of COMMAND_*.\n\
 837       The default is COMMAND_NONE.\n\
 838     completer: The kind of completer, #f, one of COMPLETE_*, or a procedure\n\
 839       to perform the completion: (lambda (self text word) ...).\n\
 840     prefix?: If true then the command is a prefix command.\n\
 841     doc: The \"doc string\" of the command.\n\
 842   Returns: <gdb:command> object" },
 843
 844   { "register-command!", 1, 0, 0, as_a_scm_t_subr (gdbscm_register_command_x),
 845     "\
 846 Register a <gdb:command> object with GDB." },
 847
 848   { "command?", 1, 0, 0, as_a_scm_t_subr (gdbscm_command_p),
 849     "\
 850 Return #t if the object is a <gdb:command> object." },
 851
 852   { "command-valid?", 1, 0, 0, as_a_scm_t_subr (gdbscm_command_valid_p),
 853     "\
 854 Return #t if the <gdb:command> object is valid." },
 855
 856   { "dont-repeat", 1, 0, 0, as_a_scm_t_subr (gdbscm_dont_repeat),
 857     "\
 858 Prevent command repetition when user enters an empty line.\n\
 859 \n\
 860   Arguments: <gdb:command>\n\
 861   Returns: unspecified" },
 862
 863   END_FUNCTIONS
 864 };
 865
 866 /* Initialize the 'commands' code.  */
 867
 868 void
 869 gdbscm_initialize_commands (void)
 870 {
 871   int i;
 872
 873   command_smob_tag
 874     = gdbscm_make_smob_type (command_smob_name, sizeof (command_smob));
 875   scm_set_smob_print (command_smob_tag, cmdscm_print_command_smob);
 876
 877   gdbscm_define_integer_constants (command_classes, 1);
 878   gdbscm_define_functions (command_functions, 1);
 879
 880   for (i = 0; i < N_COMPLETERS; ++i)
 881     {
 882       scm_c_define (cmdscm_completers[i].name, scm_from_int (i));
 883       scm_c_export (cmdscm_completers[i].name, NULL);
 884     }
 885
 886   invoke_keyword = scm_from_latin1_keyword ("invoke");
 887   command_class_keyword = scm_from_latin1_keyword ("command-class");
 888   completer_class_keyword = scm_from_latin1_keyword ("completer-class");
 889   prefix_p_keyword = scm_from_latin1_keyword ("prefix?");
 890   doc_keyword = scm_from_latin1_keyword ("doc");
 891 }