1 /* General utility routines for GDB/Scheme code.
3 Copyright (C) 2014-2019 Free Software Foundation, Inc.
5 This file is part of GDB.
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.
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.
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/>. */
20 /* See README file in this directory for implementation notes, coding
21 conventions, et.al. */
24 #include "guile-internal.h"
26 /* Define VARIABLES in the gdb module. */
29 gdbscm_define_variables (const scheme_variable *variables, int is_public)
31 const scheme_variable *sv;
33 for (sv = variables; sv->name != NULL; ++sv)
35 scm_c_define (sv->name, sv->value);
37 scm_c_export (sv->name, NULL);
41 /* Define FUNCTIONS in the gdb module. */
44 gdbscm_define_functions (const scheme_function *functions, int is_public)
46 const scheme_function *sf;
48 for (sf = functions; sf->name != NULL; ++sf)
50 SCM proc = scm_c_define_gsubr (sf->name, sf->required, sf->optional,
53 scm_set_procedure_property_x (proc, gdbscm_documentation_symbol,
54 gdbscm_scm_from_c_string (sf->doc_string));
56 scm_c_export (sf->name, NULL);
60 /* Define CONSTANTS in the gdb module. */
63 gdbscm_define_integer_constants (const scheme_integer_constant *constants,
66 const scheme_integer_constant *sc;
68 for (sc = constants; sc->name != NULL; ++sc)
70 scm_c_define (sc->name, scm_from_int (sc->value));
72 scm_c_export (sc->name, NULL);
76 /* scm_printf, alas it doesn't exist. */
79 gdbscm_printf (SCM port, const char *format, ...)
83 va_start (args, format);
84 std::string string = string_vprintf (format, args);
86 scm_puts (string.c_str (), port);
89 /* Utility for calling from gdb to "display" an SCM object. */
92 gdbscm_debug_display (SCM obj)
94 SCM port = scm_current_output_port ();
96 scm_display (obj, port);
98 scm_force_output (port);
101 /* Utility for calling from gdb to "write" an SCM object. */
104 gdbscm_debug_write (SCM obj)
106 SCM port = scm_current_output_port ();
108 scm_write (obj, port);
110 scm_force_output (port);
113 /* Subroutine of gdbscm_parse_function_args to simplify it.
114 Return the number of keyword arguments. */
117 count_keywords (const SCM *keywords)
121 if (keywords == NULL)
123 for (i = 0; keywords[i] != SCM_BOOL_F; ++i)
129 /* Subroutine of gdbscm_parse_function_args to simplify it.
130 Validate an argument format string.
131 The result is a boolean indicating if "." was seen. */
134 validate_arg_format (const char *format)
137 int length = strlen (format);
138 int optional_position = -1;
139 int keyword_position = -1;
142 gdb_assert (length > 0);
144 for (p = format; *p != '\0'; ++p)
159 gdb_assert (keyword_position < 0);
160 gdb_assert (optional_position < 0);
161 optional_position = p - format;
164 gdb_assert (keyword_position < 0);
165 keyword_position = p - format;
168 gdb_assert (p[1] == '\0');
172 gdb_assert_not_reached ("invalid argument format character");
179 /* Our version of SCM_ASSERT_TYPE that calls gdbscm_make_type_error. */
180 #define CHECK_TYPE(ok, arg, position, func_name, expected_type) \
184 return gdbscm_make_type_error ((func_name), (position), (arg), \
189 /* Subroutine of gdbscm_parse_function_args to simplify it.
190 Check the type of ARG against FORMAT_CHAR and extract the value.
191 POSITION is the position of ARG in the argument list.
192 The result is #f upon success or a <gdb:exception> object. */
195 extract_arg (char format_char, SCM arg, void *argp,
196 const char *func_name, int position)
202 char **arg_ptr = (char **) argp;
204 CHECK_TYPE (gdbscm_is_true (scm_string_p (arg)), arg, position,
205 func_name, _("string"));
206 *arg_ptr = gdbscm_scm_to_c_string (arg).release ();
211 int *arg_ptr = (int *) argp;
213 /* While in Scheme, anything non-#f is "true", we're strict. */
214 CHECK_TYPE (gdbscm_is_bool (arg), arg, position, func_name,
216 *arg_ptr = gdbscm_is_true (arg);
221 int *arg_ptr = (int *) argp;
223 CHECK_TYPE (scm_is_signed_integer (arg, INT_MIN, INT_MAX),
224 arg, position, func_name, _("int"));
225 *arg_ptr = scm_to_int (arg);
230 int *arg_ptr = (int *) argp;
232 CHECK_TYPE (scm_is_unsigned_integer (arg, 0, UINT_MAX),
233 arg, position, func_name, _("unsigned int"));
234 *arg_ptr = scm_to_uint (arg);
239 long *arg_ptr = (long *) argp;
241 CHECK_TYPE (scm_is_signed_integer (arg, LONG_MIN, LONG_MAX),
242 arg, position, func_name, _("long"));
243 *arg_ptr = scm_to_long (arg);
248 unsigned long *arg_ptr = (unsigned long *) argp;
250 CHECK_TYPE (scm_is_unsigned_integer (arg, 0, ULONG_MAX),
251 arg, position, func_name, _("unsigned long"));
252 *arg_ptr = scm_to_ulong (arg);
257 LONGEST *arg_ptr = (LONGEST *) argp;
259 CHECK_TYPE (scm_is_signed_integer (arg, INT64_MIN, INT64_MAX),
260 arg, position, func_name, _("LONGEST"));
261 *arg_ptr = gdbscm_scm_to_longest (arg);
266 ULONGEST *arg_ptr = (ULONGEST *) argp;
268 CHECK_TYPE (scm_is_unsigned_integer (arg, 0, UINT64_MAX),
269 arg, position, func_name, _("ULONGEST"));
270 *arg_ptr = gdbscm_scm_to_ulongest (arg);
275 SCM *arg_ptr = (SCM *) argp;
281 gdb_assert_not_reached ("invalid argument format character");
289 /* Look up KEYWORD in KEYWORD_LIST.
290 The result is the index of the keyword in the list or -1 if not found. */
293 lookup_keyword (const SCM *keyword_list, SCM keyword)
297 while (keyword_list[i] != SCM_BOOL_F)
299 if (scm_is_eq (keyword_list[i], keyword))
308 /* Helper for gdbscm_parse_function_args that does most of the work,
309 in a separate function wrapped with gdbscm_wrap so that we can use
310 non-trivial-dtor objects here. The result is #f upon success or a
311 <gdb:exception> object otherwise. */
314 gdbscm_parse_function_args_1 (const char *func_name,
315 int beginning_arg_pos,
317 const char *format, va_list args)
320 int i, have_rest, num_keywords, position;
321 int have_optional = 0;
324 /* Keep track of malloc'd strings. We need to free them upon error. */
325 std::vector<char *> allocated_strings;
327 have_rest = validate_arg_format (format);
328 num_keywords = count_keywords (keywords);
331 position = beginning_arg_pos;
333 /* Process required, optional arguments. */
335 while (*p && *p != '#' && *p != '.')
347 arg = va_arg (args, SCM);
348 if (!have_optional || !SCM_UNBNDP (arg))
350 arg_ptr = va_arg (args, void *);
351 status = extract_arg (*p, arg, arg_ptr, func_name, position);
352 if (!gdbscm_is_false (status))
355 allocated_strings.push_back (*(char **) arg_ptr);
361 /* Process keyword arguments. */
363 if (have_rest || num_keywords > 0)
364 rest = va_arg (args, SCM);
366 if (num_keywords > 0)
368 SCM *keyword_args = XALLOCAVEC (SCM, num_keywords);
369 int *keyword_positions = XALLOCAVEC (int, num_keywords);
371 gdb_assert (*p == '#');
374 for (i = 0; i < num_keywords; ++i)
376 keyword_args[i] = SCM_UNSPECIFIED;
377 keyword_positions[i] = -1;
380 while (scm_is_pair (rest)
381 && scm_is_keyword (scm_car (rest)))
383 SCM keyword = scm_car (rest);
385 i = lookup_keyword (keywords, keyword);
388 status = gdbscm_make_error (scm_arg_type_key, func_name,
389 _("Unrecognized keyword: ~a"),
390 scm_list_1 (keyword), keyword);
393 if (!scm_is_pair (scm_cdr (rest)))
395 status = gdbscm_make_error
396 (scm_arg_type_key, func_name,
397 _("Missing value for keyword argument"),
398 scm_list_1 (keyword), keyword);
401 keyword_args[i] = scm_cadr (rest);
402 keyword_positions[i] = position + 1;
403 rest = scm_cddr (rest);
407 for (i = 0; i < num_keywords; ++i)
409 int *arg_pos_ptr = va_arg (args, int *);
410 void *arg_ptr = va_arg (args, void *);
411 SCM arg = keyword_args[i];
413 if (! scm_is_eq (arg, SCM_UNSPECIFIED))
415 *arg_pos_ptr = keyword_positions[i];
416 status = extract_arg (p[i], arg, arg_ptr, func_name,
417 keyword_positions[i]);
418 if (!gdbscm_is_false (status))
421 allocated_strings.push_back (*(char **) arg_ptr);
426 /* Process "rest" arguments. */
430 if (num_keywords > 0)
432 SCM *rest_ptr = va_arg (args, SCM *);
439 if (! scm_is_null (rest))
441 status = gdbscm_make_error (scm_args_number_key, func_name,
442 _("Too many arguments"),
443 SCM_EOL, SCM_BOOL_F);
448 /* Return anything not-an-exception. */
452 for (char *ptr : allocated_strings)
455 /* Return the exception, which gdbscm_wrap takes care of
460 /* Utility to parse required, optional, and keyword arguments to Scheme
461 functions. Modelled on PyArg_ParseTupleAndKeywords, but no attempt is made
462 at similarity or functionality.
463 There is no result, if there's an error a Scheme exception is thrown.
465 Guile provides scm_c_bind_keyword_arguments, and feel free to use it.
466 This is for times when we want a bit more parsing.
468 BEGINNING_ARG_POS is the position of the first argument passed to this
469 routine. It should be one of the SCM_ARGn values. It could be > SCM_ARG1
470 if the caller chooses not to parse one or more required arguments.
472 KEYWORDS may be NULL if there are no keywords.
475 s - string -> char *, malloc'd
476 t - boolean (gdb uses "t", for biT?) -> int
483 O - random scheme object
484 | - indicates the next set is for optional arguments
485 # - indicates the next set is for keyword arguments (must follow |)
486 . - indicates "rest" arguments are present, this character must appear last
488 FORMAT must match the definition from scm_c_{make,define}_gsubr.
489 Required and optional arguments appear in order in the format string.
490 Afterwards, keyword-based arguments are processed. There must be as many
491 remaining characters in the format string as their are keywords.
492 Except for "|#.", the number of characters in the format string must match
493 #required + #optional + #keywords.
495 The function is required to be defined in a compatible manner:
496 #required-args and #optional-arguments must match, and rest-arguments
497 must be specified if keyword args are desired, and/or regular "rest" args.
499 Example: For this function,
500 scm_c_define_gsubr ("execute", 2, 3, 1, foo);
501 the format string + keyword list could be any of:
502 1) "ss|ttt#tt", { "key1", "key2", NULL }
503 2) "ss|ttt.", { NULL }
504 3) "ss|ttt#t.", { "key1", NULL }
506 For required and optional args pass the SCM of the argument, and a
507 pointer to the value to hold the parsed result (type depends on format
508 char). After that pass the SCM containing the "rest" arguments followed
509 by pointers to values to hold parsed keyword arguments, and if specified
510 a pointer to hold the remaining contents of "rest".
512 For keyword arguments pass two pointers: the first is a pointer to an int
513 that will contain the position of the argument in the arg list, and the
514 second will contain result of processing the argument. The int pointed
515 to by the first value should be initialized to -1. It can then be used
516 to tell whether the keyword was present.
518 If both keyword and rest arguments are present, the caller must pass a
519 pointer to contain the new value of rest (after keyword args have been
522 There's currently no way, that I know of, to specify default values for
523 optional arguments in C-provided functions. At the moment they're a
524 work-in-progress. The caller should test SCM_UNBNDP for each optional
525 argument. Unbound optional arguments are ignored. */
528 gdbscm_parse_function_args (const char *func_name,
529 int beginning_arg_pos,
531 const char *format, ...)
534 va_start (args, format);
536 gdbscm_wrap (gdbscm_parse_function_args_1, func_name,
537 beginning_arg_pos, keywords, format, args);
543 /* Return longest L as a scheme object. */
546 gdbscm_scm_from_longest (LONGEST l)
548 return scm_from_int64 (l);
551 /* Convert scheme object L to LONGEST.
552 It is an error to call this if L is not an integer in range of LONGEST.
553 (because the underlying Scheme function will thrown an exception,
554 which is not part of our contract with the caller). */
557 gdbscm_scm_to_longest (SCM l)
559 return scm_to_int64 (l);
562 /* Return unsigned longest L as a scheme object. */
565 gdbscm_scm_from_ulongest (ULONGEST l)
567 return scm_from_uint64 (l);
570 /* Convert scheme object U to ULONGEST.
571 It is an error to call this if U is not an integer in range of ULONGEST
572 (because the underlying Scheme function will thrown an exception,
573 which is not part of our contract with the caller). */
576 gdbscm_scm_to_ulongest (SCM u)
578 return scm_to_uint64 (u);
581 /* Same as scm_dynwind_free, but uses xfree. */
584 gdbscm_dynwind_xfree (void *ptr)
586 scm_dynwind_unwind_handler (xfree, ptr, SCM_F_WIND_EXPLICITLY);
589 /* Return non-zero if PROC is a procedure. */
592 gdbscm_is_procedure (SCM proc)
594 return gdbscm_is_true (scm_procedure_p (proc));
597 /* Same as xstrdup, but the string is allocated on the GC heap. */
600 gdbscm_gc_xstrdup (const char *str)
602 size_t len = strlen (str);
604 = (char *) scm_gc_malloc_pointerless (len + 1, "gdbscm_gc_xstrdup");
606 strcpy (result, str);
610 /* Return a duplicate of ARGV living on the GC heap. */
613 gdbscm_gc_dup_argv (char **argv)
619 for (len = 0, string_space = 0; argv[len] != NULL; ++len)
620 string_space += strlen (argv[len]) + 1;
622 /* Allocating "pointerless" works because the pointers are all
623 self-contained within the object. */
624 result = (char **) scm_gc_malloc_pointerless (((len + 1) * sizeof (char *))
626 "parameter enum list");
627 p = (char *) &result[len + 1];
629 for (i = 0; i < len; ++i)
637 return (const char * const *) result;
640 /* Return non-zero if the version of Guile being used it at least
641 MAJOR.MINOR.MICRO. */
644 gdbscm_guile_version_is_at_least (int major, int minor, int micro)
646 if (major > gdbscm_guile_major_version)
648 if (major < gdbscm_guile_major_version)
650 if (minor > gdbscm_guile_minor_version)
652 if (minor < gdbscm_guile_minor_version)
654 if (micro > gdbscm_guile_micro_version)