xref: /netbsd-src/external/gpl3/gdb.old/dist/gdb/guile/scm-cmd.c (revision 181254a7b1bdde6873432bffef2d2decc4b5c22f)
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 
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 
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 
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,
295 		 char *args_entry, int from_tty)
296 {
297   const char *args = args_entry;
298   command_smob *c_smob/*obj*/ = (command_smob *) get_cmd_context (command);
299   SCM arg_scm, tty_scm, result;
300 
301   gdb_assert (c_smob != NULL);
302 
303   if (args == NULL)
304     args = "";
305   arg_scm = gdbscm_scm_from_string (args, strlen (args), host_charset (), 1);
306   if (gdbscm_is_exception (arg_scm))
307     error (_("Could not convert arguments to Scheme string."));
308 
309   tty_scm = scm_from_bool (from_tty);
310 
311   result = gdbscm_safe_call_3 (c_smob->invoke, c_smob->containing_scm,
312 			       arg_scm, tty_scm, gdbscm_user_error_p);
313 
314   if (gdbscm_is_exception (result))
315     {
316       /* Don't print the stack if this was an error signalled by the command
317 	 itself.  */
318       if (gdbscm_user_error_p (gdbscm_exception_key (result)))
319 	{
320 	  char *msg = gdbscm_exception_message_to_string (result);
321 
322 	  make_cleanup (xfree, msg);
323 	  error ("%s", msg);
324 	}
325       else
326 	{
327 	  gdbscm_print_gdb_exception (SCM_BOOL_F, result);
328 	  error (_("Error occurred in Scheme-implemented GDB command."));
329 	}
330     }
331 }
332 
333 /* Subroutine of cmdscm_completer to simplify it.
334    Print an error message indicating that COMPLETION is a bad completion
335    result.  */
336 
337 static void
338 cmdscm_bad_completion_result (const char *msg, SCM completion)
339 {
340   SCM port = scm_current_error_port ();
341 
342   scm_puts (msg, port);
343   scm_display (completion, port);
344   scm_newline (port);
345 }
346 
347 /* Subroutine of cmdscm_completer to simplify it.
348    Validate COMPLETION and add to RESULT.
349    If an error occurs print an error message.
350    The result is a boolean indicating success.  */
351 
352 static int
353 cmdscm_add_completion (SCM completion, VEC (char_ptr) **result)
354 {
355   char *item;
356   SCM except_scm;
357 
358   if (!scm_is_string (completion))
359     {
360       /* Inform the user, but otherwise ignore the entire result.  */
361       cmdscm_bad_completion_result (_("Bad text from completer: "),
362 				    completion);
363       return 0;
364     }
365 
366   item = gdbscm_scm_to_string (completion, NULL, host_charset (), 1,
367 			       &except_scm);
368   if (item == NULL)
369     {
370       /* Inform the user, but otherwise ignore the entire result.  */
371       gdbscm_print_gdb_exception (SCM_BOOL_F, except_scm);
372       return 0;
373     }
374 
375   VEC_safe_push (char_ptr, *result, item);
376 
377   return 1;
378 }
379 
380 /* Called by gdb for command completion.  */
381 
382 static VEC (char_ptr) *
383 cmdscm_completer (struct cmd_list_element *command,
384 		  const char *text, const char *word)
385 {
386   command_smob *c_smob/*obj*/ = (command_smob *) get_cmd_context (command);
387   SCM completer_result_scm;
388   SCM text_scm, word_scm, result_scm;
389   VEC (char_ptr) *result = NULL;
390 
391   gdb_assert (c_smob != NULL);
392   gdb_assert (gdbscm_is_procedure (c_smob->complete));
393 
394   text_scm = gdbscm_scm_from_string (text, strlen (text), host_charset (),
395 				     1);
396   if (gdbscm_is_exception (text_scm))
397     error (_("Could not convert \"text\" argument to Scheme string."));
398   word_scm = gdbscm_scm_from_string (word, strlen (word), host_charset (),
399 				     1);
400   if (gdbscm_is_exception (word_scm))
401     error (_("Could not convert \"word\" argument to Scheme string."));
402 
403   completer_result_scm
404     = gdbscm_safe_call_3 (c_smob->complete, c_smob->containing_scm,
405 			  text_scm, word_scm, NULL);
406 
407   if (gdbscm_is_exception (completer_result_scm))
408     {
409       /* Inform the user, but otherwise ignore.  */
410       gdbscm_print_gdb_exception (SCM_BOOL_F, completer_result_scm);
411       goto done;
412     }
413 
414   if (gdbscm_is_true (scm_list_p (completer_result_scm)))
415     {
416       SCM list = completer_result_scm;
417 
418       while (!scm_is_eq (list, SCM_EOL))
419 	{
420 	  SCM next = scm_car (list);
421 
422 	  if (!cmdscm_add_completion (next, &result))
423 	    {
424 	      VEC_free (char_ptr, result);
425 	      goto done;
426 	    }
427 
428 	  list = scm_cdr (list);
429 	}
430     }
431   else if (itscm_is_iterator (completer_result_scm))
432     {
433       SCM iter = completer_result_scm;
434       SCM next = itscm_safe_call_next_x (iter, NULL);
435 
436       while (gdbscm_is_true (next))
437 	{
438 	  if (gdbscm_is_exception (next))
439 	    {
440 	      /* Inform the user, but otherwise ignore the entire result.  */
441 	      gdbscm_print_gdb_exception (SCM_BOOL_F, completer_result_scm);
442 	      VEC_free (char_ptr, result);
443 	      goto done;
444 	    }
445 
446 	  if (!cmdscm_add_completion (next, &result))
447 	    {
448 	      VEC_free (char_ptr, result);
449 	      goto done;
450 	    }
451 
452 	  next = itscm_safe_call_next_x (iter, NULL);
453 	}
454     }
455   else
456     {
457       /* Inform the user, but otherwise ignore.  */
458       cmdscm_bad_completion_result (_("Bad completer result: "),
459 				    completer_result_scm);
460     }
461 
462  done:
463   return result;
464 }
465 
466 /* Helper for gdbscm_make_command which locates the command list to use and
467    pulls out the command name.
468 
469    NAME is the command name list.  The final word in the list is the
470    name of the new command.  All earlier words must be existing prefix
471    commands.
472 
473    *BASE_LIST is set to the final prefix command's list of
474    *sub-commands.
475 
476    START_LIST is the list in which the search starts.
477 
478    This function returns the xmalloc()d name of the new command.
479    On error a Scheme exception is thrown.  */
480 
481 char *
482 gdbscm_parse_command_name (const char *name,
483 			   const char *func_name, int arg_pos,
484 			   struct cmd_list_element ***base_list,
485 			   struct cmd_list_element **start_list)
486 {
487   struct cmd_list_element *elt;
488   int len = strlen (name);
489   int i, lastchar;
490   char *prefix_text;
491   const char *prefix_text2;
492   char *result, *msg;
493 
494   /* Skip trailing whitespace.  */
495   for (i = len - 1; i >= 0 && (name[i] == ' ' || name[i] == '\t'); --i)
496     ;
497   if (i < 0)
498     {
499       gdbscm_out_of_range_error (func_name, arg_pos,
500 				 gdbscm_scm_from_c_string (name),
501 				 _("no command name found"));
502     }
503   lastchar = i;
504 
505   /* Find first character of the final word.  */
506   for (; i > 0 && (isalnum (name[i - 1])
507 		   || name[i - 1] == '-'
508 		   || name[i - 1] == '_');
509        --i)
510     ;
511   result = (char *) xmalloc (lastchar - i + 2);
512   memcpy (result, &name[i], lastchar - i + 1);
513   result[lastchar - i + 1] = '\0';
514 
515   /* Skip whitespace again.  */
516   for (--i; i >= 0 && (name[i] == ' ' || name[i] == '\t'); --i)
517     ;
518   if (i < 0)
519     {
520       *base_list = start_list;
521       return result;
522     }
523 
524   prefix_text = (char *) xmalloc (i + 2);
525   memcpy (prefix_text, name, i + 1);
526   prefix_text[i + 1] = '\0';
527 
528   prefix_text2 = prefix_text;
529   elt = lookup_cmd_1 (&prefix_text2, *start_list, NULL, 1);
530   if (elt == NULL || elt == CMD_LIST_AMBIGUOUS)
531     {
532       msg = xstrprintf (_("could not find command prefix '%s'"), prefix_text);
533       xfree (prefix_text);
534       xfree (result);
535       scm_dynwind_begin ((scm_t_dynwind_flags) 0);
536       gdbscm_dynwind_xfree (msg);
537       gdbscm_out_of_range_error (func_name, arg_pos,
538 				 gdbscm_scm_from_c_string (name), msg);
539     }
540 
541   if (elt->prefixlist)
542     {
543       xfree (prefix_text);
544       *base_list = elt->prefixlist;
545       return result;
546     }
547 
548   msg = xstrprintf (_("'%s' is not a prefix command"), prefix_text);
549   xfree (prefix_text);
550   xfree (result);
551   scm_dynwind_begin ((scm_t_dynwind_flags) 0);
552   gdbscm_dynwind_xfree (msg);
553   gdbscm_out_of_range_error (func_name, arg_pos,
554 			     gdbscm_scm_from_c_string (name), msg);
555   /* NOTREACHED */
556 }
557 
558 static const scheme_integer_constant command_classes[] =
559 {
560   /* Note: alias and user are special; pseudo appears to be unused,
561      and there is no reason to expose tui, I think.  */
562   { "COMMAND_NONE", no_class },
563   { "COMMAND_RUNNING", class_run },
564   { "COMMAND_DATA", class_vars },
565   { "COMMAND_STACK", class_stack },
566   { "COMMAND_FILES", class_files },
567   { "COMMAND_SUPPORT", class_support },
568   { "COMMAND_STATUS", class_info },
569   { "COMMAND_BREAKPOINTS", class_breakpoint },
570   { "COMMAND_TRACEPOINTS", class_trace },
571   { "COMMAND_OBSCURE", class_obscure },
572   { "COMMAND_MAINTENANCE", class_maintenance },
573   { "COMMAND_USER", class_user },
574 
575   END_INTEGER_CONSTANTS
576 };
577 
578 /* Return non-zero if command_class is a valid command class.  */
579 
580 int
581 gdbscm_valid_command_class_p (int command_class)
582 {
583   int i;
584 
585   for (i = 0; command_classes[i].name != NULL; ++i)
586     {
587       if (command_classes[i].value == command_class)
588 	return 1;
589     }
590 
591   return 0;
592 }
593 
594 /* Return a normalized form of command NAME.
595    That is tabs are replaced with spaces and multiple spaces are replaced
596    with a single space.
597    If WANT_TRAILING_SPACE is non-zero, add one space at the end.  This is for
598    prefix commands.
599    but that is the caller's responsibility.
600    Space for the result is allocated on the GC heap.  */
601 
602 char *
603 gdbscm_canonicalize_command_name (const char *name, int want_trailing_space)
604 {
605   int i, out, seen_word;
606   char *result
607     = (char *) scm_gc_malloc_pointerless (strlen (name) + 2, FUNC_NAME);
608 
609   i = out = seen_word = 0;
610   while (name[i])
611     {
612       /* Skip whitespace.  */
613       while (name[i] == ' ' || name[i] == '\t')
614 	++i;
615       /* Copy non-whitespace characters.  */
616       if (name[i])
617 	{
618 	  if (seen_word)
619 	    result[out++] = ' ';
620 	  while (name[i] && name[i] != ' ' && name[i] != '\t')
621 	    result[out++] = name[i++];
622 	  seen_word = 1;
623 	}
624     }
625   if (want_trailing_space)
626     result[out++] = ' ';
627   result[out] = '\0';
628 
629   return result;
630 }
631 
632 /* (make-command name [#:invoke lambda]
633      [#:command-class class] [#:completer-class completer]
634      [#:prefix? <bool>] [#:doc <string>]) -> <gdb:command>
635 
636    NAME is the name of the command.  It may consist of multiple words,
637    in which case the final word is the name of the new command, and
638    earlier words must be prefix commands.
639 
640    INVOKE is a procedure of three arguments that performs the command when
641    invoked: (lambda (self arg from-tty) ...).
642    Its result is unspecified.
643 
644    CLASS is the kind of command.  It must be one of the COMMAND_*
645    constants defined in the gdb module.  If not specified, "no_class" is used.
646 
647    COMPLETER is the kind of completer.  It must be either:
648      #f - completion is not supported for this command.
649      One of the COMPLETE_* constants defined in the gdb module.
650      A procedure of three arguments: (lambda (self text word) ...).
651        Its result is one of:
652          A list of strings.
653          A <gdb:iterator> object that returns the set of possible completions,
654          ending with #f.
655 	 TODO(dje): Once PR 16699 is fixed, add support for returning
656 	 a COMPLETE_* constant.
657    If not specified, then completion is not supported for this command.
658 
659    If PREFIX is #t, then this command is a prefix command.
660 
661    DOC is the doc string for the command.
662 
663    The result is the <gdb:command> Scheme object.
664    The command is not available to be used yet, however.
665    It must still be added to gdb with register-command!.  */
666 
667 static SCM
668 gdbscm_make_command (SCM name_scm, SCM rest)
669 {
670   const SCM keywords[] = {
671     invoke_keyword, command_class_keyword, completer_class_keyword,
672     prefix_p_keyword, doc_keyword, SCM_BOOL_F
673   };
674   int invoke_arg_pos = -1, command_class_arg_pos = 1;
675   int completer_class_arg_pos = -1, is_prefix_arg_pos = -1;
676   int doc_arg_pos = -1;
677   char *s;
678   char *name;
679   enum command_class command_class = no_class;
680   SCM completer_class = SCM_BOOL_F;
681   int is_prefix = 0;
682   char *doc = NULL;
683   SCM invoke = SCM_BOOL_F;
684   SCM c_scm;
685   command_smob *c_smob;
686 
687   gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, keywords, "s#OiOts",
688 			      name_scm, &name, rest,
689 			      &invoke_arg_pos, &invoke,
690 			      &command_class_arg_pos, &command_class,
691 			      &completer_class_arg_pos, &completer_class,
692 			      &is_prefix_arg_pos, &is_prefix,
693 			      &doc_arg_pos, &doc);
694 
695   if (doc == NULL)
696     doc = xstrdup (_("This command is not documented."));
697 
698   s = name;
699   name = gdbscm_canonicalize_command_name (s, is_prefix);
700   xfree (s);
701   s = doc;
702   doc = gdbscm_gc_xstrdup (s);
703   xfree (s);
704 
705   if (is_prefix
706       ? name[0] == ' '
707       : name[0] == '\0')
708     {
709       gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, name_scm,
710 				 _("no command name found"));
711     }
712 
713   if (gdbscm_is_true (invoke))
714     {
715       SCM_ASSERT_TYPE (gdbscm_is_procedure (invoke), invoke,
716 		       invoke_arg_pos, FUNC_NAME, _("procedure"));
717     }
718 
719   if (!gdbscm_valid_command_class_p (command_class))
720     {
721       gdbscm_out_of_range_error (FUNC_NAME, command_class_arg_pos,
722 				 scm_from_int (command_class),
723 				 _("invalid command class argument"));
724     }
725 
726   SCM_ASSERT_TYPE (gdbscm_is_false (completer_class)
727 		   || scm_is_integer (completer_class)
728 		   || gdbscm_is_procedure (completer_class),
729 		   completer_class, completer_class_arg_pos, FUNC_NAME,
730 		   _("integer or procedure"));
731   if (scm_is_integer (completer_class)
732       && !scm_is_signed_integer (completer_class, 0, N_COMPLETERS - 1))
733     {
734       gdbscm_out_of_range_error (FUNC_NAME, completer_class_arg_pos,
735 				 completer_class,
736 				 _("invalid completion type argument"));
737     }
738 
739   c_scm = cmdscm_make_command_smob ();
740   c_smob = (command_smob *) SCM_SMOB_DATA (c_scm);
741   c_smob->name = name;
742   c_smob->is_prefix = is_prefix;
743   c_smob->cmd_class = command_class;
744   c_smob->doc = doc;
745   c_smob->invoke = invoke;
746   c_smob->complete = completer_class;
747 
748   return c_scm;
749 }
750 
751 /* (register-command! <gdb:command>) -> unspecified
752 
753    It is an error to register a command more than once.  */
754 
755 static SCM
756 gdbscm_register_command_x (SCM self)
757 {
758   command_smob *c_smob
759     = cmdscm_get_command_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
760   char *cmd_name, *pfx_name;
761   struct cmd_list_element **cmd_list;
762   struct cmd_list_element *cmd = NULL;
763 
764   if (cmdscm_is_valid (c_smob))
765     scm_misc_error (FUNC_NAME, _("command is already registered"), SCM_EOL);
766 
767   cmd_name = gdbscm_parse_command_name (c_smob->name, FUNC_NAME, SCM_ARG1,
768 					&cmd_list, &cmdlist);
769   c_smob->cmd_name = gdbscm_gc_xstrdup (cmd_name);
770   xfree (cmd_name);
771 
772   TRY
773     {
774       if (c_smob->is_prefix)
775 	{
776 	  /* If we have our own "invoke" method, then allow unknown
777 	     sub-commands.  */
778 	  int allow_unknown = gdbscm_is_true (c_smob->invoke);
779 
780 	  cmd = add_prefix_cmd (c_smob->cmd_name, c_smob->cmd_class,
781 				NULL, c_smob->doc, &c_smob->sub_list,
782 				c_smob->name, allow_unknown, cmd_list);
783 	}
784       else
785 	{
786 	  cmd = add_cmd (c_smob->cmd_name, c_smob->cmd_class,
787 			 NULL, c_smob->doc, cmd_list);
788 	}
789     }
790   CATCH (except, RETURN_MASK_ALL)
791     {
792       GDBSCM_HANDLE_GDB_EXCEPTION (except);
793     }
794   END_CATCH
795 
796   /* Note: At this point the command exists in gdb.
797      So no more errors after this point.  */
798 
799   /* There appears to be no API to set this.  */
800   cmd->func = cmdscm_function;
801   cmd->destroyer = cmdscm_destroyer;
802 
803   c_smob->command = cmd;
804   set_cmd_context (cmd, c_smob);
805 
806   if (gdbscm_is_true (c_smob->complete))
807     {
808       set_cmd_completer (cmd,
809 			 scm_is_integer (c_smob->complete)
810 			 ? cmdscm_completers[scm_to_int (c_smob->complete)].completer
811 			 : cmdscm_completer);
812     }
813 
814   /* The owner of this command is not in GC-controlled memory, so we need
815      to protect it from GC until the command is deleted.  */
816   scm_gc_protect_object (c_smob->containing_scm);
817 
818   return SCM_UNSPECIFIED;
819 }
820 
821 /* Initialize the Scheme command support.  */
822 
823 static const scheme_function command_functions[] =
824 {
825   { "make-command", 1, 0, 1, as_a_scm_t_subr (gdbscm_make_command),
826     "\
827 Make a GDB command object.\n\
828 \n\
829   Arguments: name [#:invoke lambda]\n\
830       [#:command-class <class>] [#:completer-class <completer>]\n\
831       [#:prefix? <bool>] [#:doc string]\n\
832     name: The name of the command.  It may consist of multiple words,\n\
833       in which case the final word is the name of the new command, and\n\
834       earlier words must be prefix commands.\n\
835     invoke: A procedure of three arguments to perform the command.\n\
836       (lambda (self arg from-tty) ...)\n\
837       Its result is unspecified.\n\
838     class: The class of the command, one of COMMAND_*.\n\
839       The default is COMMAND_NONE.\n\
840     completer: The kind of completer, #f, one of COMPLETE_*, or a procedure\n\
841       to perform the completion: (lambda (self text word) ...).\n\
842     prefix?: If true then the command is a prefix command.\n\
843     doc: The \"doc string\" of the command.\n\
844   Returns: <gdb:command> object" },
845 
846   { "register-command!", 1, 0, 0, as_a_scm_t_subr (gdbscm_register_command_x),
847     "\
848 Register a <gdb:command> object with GDB." },
849 
850   { "command?", 1, 0, 0, as_a_scm_t_subr (gdbscm_command_p),
851     "\
852 Return #t if the object is a <gdb:command> object." },
853 
854   { "command-valid?", 1, 0, 0, as_a_scm_t_subr (gdbscm_command_valid_p),
855     "\
856 Return #t if the <gdb:command> object is valid." },
857 
858   { "dont-repeat", 1, 0, 0, as_a_scm_t_subr (gdbscm_dont_repeat),
859     "\
860 Prevent command repetition when user enters an empty line.\n\
861 \n\
862   Arguments: <gdb:command>\n\
863   Returns: unspecified" },
864 
865   END_FUNCTIONS
866 };
867 
868 /* Initialize the 'commands' code.  */
869 
870 void
871 gdbscm_initialize_commands (void)
872 {
873   int i;
874 
875   command_smob_tag
876     = gdbscm_make_smob_type (command_smob_name, sizeof (command_smob));
877   scm_set_smob_print (command_smob_tag, cmdscm_print_command_smob);
878 
879   gdbscm_define_integer_constants (command_classes, 1);
880   gdbscm_define_functions (command_functions, 1);
881 
882   for (i = 0; i < N_COMPLETERS; ++i)
883     {
884       scm_c_define (cmdscm_completers[i].name, scm_from_int (i));
885       scm_c_export (cmdscm_completers[i].name, NULL);
886     }
887 
888   invoke_keyword = scm_from_latin1_keyword ("invoke");
889   command_class_keyword = scm_from_latin1_keyword ("command-class");
890   completer_class_keyword = scm_from_latin1_keyword ("completer-class");
891   prefix_p_keyword = scm_from_latin1_keyword ("prefix?");
892   doc_keyword = scm_from_latin1_keyword ("doc");
893 }
894