1 /* General utility routines for GDB/Scheme code.
3 Copyright (C) 2014-2015 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
, ...)
84 va_start (args
, format
);
85 string
= xstrvprintf (format
, args
);
87 scm_puts (string
, port
);
91 /* Utility for calling from gdb to "display" an SCM object. */
94 gdbscm_debug_display (SCM obj
)
96 SCM port
= scm_current_output_port ();
98 scm_display (obj
, port
);
100 scm_force_output (port
);
103 /* Utility for calling from gdb to "write" an SCM object. */
106 gdbscm_debug_write (SCM obj
)
108 SCM port
= scm_current_output_port ();
110 scm_write (obj
, port
);
112 scm_force_output (port
);
115 /* Subroutine of gdbscm_parse_function_args to simplify it.
116 Return the number of keyword arguments. */
119 count_keywords (const SCM
*keywords
)
123 if (keywords
== NULL
)
125 for (i
= 0; keywords
[i
] != SCM_BOOL_F
; ++i
)
131 /* Subroutine of gdbscm_parse_function_args to simplify it.
132 Validate an argument format string.
133 The result is a boolean indicating if "." was seen. */
136 validate_arg_format (const char *format
)
139 int length
= strlen (format
);
140 int optional_position
= -1;
141 int keyword_position
= -1;
144 gdb_assert (length
> 0);
146 for (p
= format
; *p
!= '\0'; ++p
)
161 gdb_assert (keyword_position
< 0);
162 gdb_assert (optional_position
< 0);
163 optional_position
= p
- format
;
166 gdb_assert (keyword_position
< 0);
167 keyword_position
= p
- format
;
170 gdb_assert (p
[1] == '\0');
174 gdb_assert_not_reached ("invalid argument format character");
181 /* Our version of SCM_ASSERT_TYPE that calls gdbscm_make_type_error. */
182 #define CHECK_TYPE(ok, arg, position, func_name, expected_type) \
186 return gdbscm_make_type_error ((func_name), (position), (arg), \
191 /* Subroutine of gdbscm_parse_function_args to simplify it.
192 Check the type of ARG against FORMAT_CHAR and extract the value.
193 POSITION is the position of ARG in the argument list.
194 The result is #f upon success or a <gdb:exception> object. */
197 extract_arg (char format_char
, SCM arg
, void *argp
,
198 const char *func_name
, int position
)
204 char **arg_ptr
= argp
;
206 CHECK_TYPE (gdbscm_is_true (scm_string_p (arg
)), arg
, position
,
207 func_name
, _("string"));
208 *arg_ptr
= gdbscm_scm_to_c_string (arg
);
215 /* While in Scheme, anything non-#f is "true", we're strict. */
216 CHECK_TYPE (gdbscm_is_bool (arg
), arg
, position
, func_name
,
218 *arg_ptr
= gdbscm_is_true (arg
);
225 CHECK_TYPE (scm_is_signed_integer (arg
, INT_MIN
, INT_MAX
),
226 arg
, position
, func_name
, _("int"));
227 *arg_ptr
= scm_to_int (arg
);
234 CHECK_TYPE (scm_is_unsigned_integer (arg
, 0, UINT_MAX
),
235 arg
, position
, func_name
, _("unsigned int"));
236 *arg_ptr
= scm_to_uint (arg
);
241 long *arg_ptr
= argp
;
243 CHECK_TYPE (scm_is_signed_integer (arg
, LONG_MIN
, LONG_MAX
),
244 arg
, position
, func_name
, _("long"));
245 *arg_ptr
= scm_to_long (arg
);
250 unsigned long *arg_ptr
= argp
;
252 CHECK_TYPE (scm_is_unsigned_integer (arg
, 0, ULONG_MAX
),
253 arg
, position
, func_name
, _("unsigned long"));
254 *arg_ptr
= scm_to_ulong (arg
);
259 LONGEST
*arg_ptr
= argp
;
261 CHECK_TYPE (scm_is_signed_integer (arg
, INT64_MIN
, INT64_MAX
),
262 arg
, position
, func_name
, _("LONGEST"));
263 *arg_ptr
= gdbscm_scm_to_longest (arg
);
268 ULONGEST
*arg_ptr
= argp
;
270 CHECK_TYPE (scm_is_unsigned_integer (arg
, 0, UINT64_MAX
),
271 arg
, position
, func_name
, _("ULONGEST"));
272 *arg_ptr
= gdbscm_scm_to_ulongest (arg
);
283 gdb_assert_not_reached ("invalid argument format character");
291 /* Look up KEYWORD in KEYWORD_LIST.
292 The result is the index of the keyword in the list or -1 if not found. */
295 lookup_keyword (const SCM
*keyword_list
, SCM keyword
)
299 while (keyword_list
[i
] != SCM_BOOL_F
)
301 if (scm_is_eq (keyword_list
[i
], keyword
))
309 /* Utility to parse required, optional, and keyword arguments to Scheme
310 functions. Modelled on PyArg_ParseTupleAndKeywords, but no attempt is made
311 at similarity or functionality.
312 There is no result, if there's an error a Scheme exception is thrown.
314 Guile provides scm_c_bind_keyword_arguments, and feel free to use it.
315 This is for times when we want a bit more parsing.
317 BEGINNING_ARG_POS is the position of the first argument passed to this
318 routine. It should be one of the SCM_ARGn values. It could be > SCM_ARG1
319 if the caller chooses not to parse one or more required arguments.
321 KEYWORDS may be NULL if there are no keywords.
324 s - string -> char *, malloc'd
325 t - boolean (gdb uses "t", for biT?) -> int
332 O - random scheme object
333 | - indicates the next set is for optional arguments
334 # - indicates the next set is for keyword arguments (must follow |)
335 . - indicates "rest" arguments are present, this character must appear last
337 FORMAT must match the definition from scm_c_{make,define}_gsubr.
338 Required and optional arguments appear in order in the format string.
339 Afterwards, keyword-based arguments are processed. There must be as many
340 remaining characters in the format string as their are keywords.
341 Except for "|#.", the number of characters in the format string must match
342 #required + #optional + #keywords.
344 The function is required to be defined in a compatible manner:
345 #required-args and #optional-arguments must match, and rest-arguments
346 must be specified if keyword args are desired, and/or regular "rest" args.
348 Example: For this function,
349 scm_c_define_gsubr ("execute", 2, 3, 1, foo);
350 the format string + keyword list could be any of:
351 1) "ss|ttt#tt", { "key1", "key2", NULL }
352 2) "ss|ttt.", { NULL }
353 3) "ss|ttt#t.", { "key1", NULL }
355 For required and optional args pass the SCM of the argument, and a
356 pointer to the value to hold the parsed result (type depends on format
357 char). After that pass the SCM containing the "rest" arguments followed
358 by pointers to values to hold parsed keyword arguments, and if specified
359 a pointer to hold the remaining contents of "rest".
361 For keyword arguments pass two pointers: the first is a pointer to an int
362 that will contain the position of the argument in the arg list, and the
363 second will contain result of processing the argument. The int pointed
364 to by the first value should be initialized to -1. It can then be used
365 to tell whether the keyword was present.
367 If both keyword and rest arguments are present, the caller must pass a
368 pointer to contain the new value of rest (after keyword args have been
371 There's currently no way, that I know of, to specify default values for
372 optional arguments in C-provided functions. At the moment they're a
373 work-in-progress. The caller should test SCM_UNBNDP for each optional
374 argument. Unbound optional arguments are ignored. */
377 gdbscm_parse_function_args (const char *func_name
,
378 int beginning_arg_pos
,
380 const char *format
, ...)
384 int i
, have_rest
, num_keywords
, length
, position
;
385 int have_optional
= 0;
388 /* Keep track of malloc'd strings. We need to free them upon error. */
389 VEC (char_ptr
) *allocated_strings
= NULL
;
392 have_rest
= validate_arg_format (format
);
393 num_keywords
= count_keywords (keywords
);
395 va_start (args
, format
);
398 position
= beginning_arg_pos
;
400 /* Process required, optional arguments. */
402 while (*p
&& *p
!= '#' && *p
!= '.')
414 arg
= va_arg (args
, SCM
);
415 if (!have_optional
|| !SCM_UNBNDP (arg
))
417 arg_ptr
= va_arg (args
, void *);
418 status
= extract_arg (*p
, arg
, arg_ptr
, func_name
, position
);
419 if (!gdbscm_is_false (status
))
422 VEC_safe_push (char_ptr
, allocated_strings
, *(char **) arg_ptr
);
428 /* Process keyword arguments. */
430 if (have_rest
|| num_keywords
> 0)
431 rest
= va_arg (args
, SCM
);
433 if (num_keywords
> 0)
435 SCM
*keyword_args
= (SCM
*) alloca (num_keywords
* sizeof (SCM
));
436 int *keyword_positions
= (int *) alloca (num_keywords
* sizeof (int));
438 gdb_assert (*p
== '#');
441 for (i
= 0; i
< num_keywords
; ++i
)
443 keyword_args
[i
] = SCM_UNSPECIFIED
;
444 keyword_positions
[i
] = -1;
447 while (scm_is_pair (rest
)
448 && scm_is_keyword (scm_car (rest
)))
450 SCM keyword
= scm_car (rest
);
452 i
= lookup_keyword (keywords
, keyword
);
455 status
= gdbscm_make_error (scm_arg_type_key
, func_name
,
456 _("Unrecognized keyword: ~a"),
457 scm_list_1 (keyword
), keyword
);
460 if (!scm_is_pair (scm_cdr (rest
)))
462 status
= gdbscm_make_error
463 (scm_arg_type_key
, func_name
,
464 _("Missing value for keyword argument"),
465 scm_list_1 (keyword
), keyword
);
468 keyword_args
[i
] = scm_cadr (rest
);
469 keyword_positions
[i
] = position
+ 1;
470 rest
= scm_cddr (rest
);
474 for (i
= 0; i
< num_keywords
; ++i
)
476 int *arg_pos_ptr
= va_arg (args
, int *);
477 void *arg_ptr
= va_arg (args
, void *);
478 SCM arg
= keyword_args
[i
];
480 if (! scm_is_eq (arg
, SCM_UNSPECIFIED
))
482 *arg_pos_ptr
= keyword_positions
[i
];
483 status
= extract_arg (p
[i
], arg
, arg_ptr
, func_name
,
484 keyword_positions
[i
]);
485 if (!gdbscm_is_false (status
))
489 VEC_safe_push (char_ptr
, allocated_strings
,
496 /* Process "rest" arguments. */
500 if (num_keywords
> 0)
502 SCM
*rest_ptr
= va_arg (args
, SCM
*);
509 if (! scm_is_null (rest
))
511 status
= gdbscm_make_error (scm_args_number_key
, func_name
,
512 _("Too many arguments"),
513 SCM_EOL
, SCM_BOOL_F
);
519 VEC_free (char_ptr
, allocated_strings
);
524 for (i
= 0; VEC_iterate (char_ptr
, allocated_strings
, i
, ptr
); ++i
)
526 VEC_free (char_ptr
, allocated_strings
);
527 gdbscm_throw (status
);
530 /* Return longest L as a scheme object. */
533 gdbscm_scm_from_longest (LONGEST l
)
535 return scm_from_int64 (l
);
538 /* Convert scheme object L to LONGEST.
539 It is an error to call this if L is not an integer in range of LONGEST.
540 (because the underlying Scheme function will thrown an exception,
541 which is not part of our contract with the caller). */
544 gdbscm_scm_to_longest (SCM l
)
546 return scm_to_int64 (l
);
549 /* Return unsigned longest L as a scheme object. */
552 gdbscm_scm_from_ulongest (ULONGEST l
)
554 return scm_from_uint64 (l
);
557 /* Convert scheme object U to ULONGEST.
558 It is an error to call this if U is not an integer in range of ULONGEST
559 (because the underlying Scheme function will thrown an exception,
560 which is not part of our contract with the caller). */
563 gdbscm_scm_to_ulongest (SCM u
)
565 return scm_to_uint64 (u
);
568 /* Same as scm_dynwind_free, but uses xfree. */
571 gdbscm_dynwind_xfree (void *ptr
)
573 scm_dynwind_unwind_handler (xfree
, ptr
, SCM_F_WIND_EXPLICITLY
);
576 /* Return non-zero if PROC is a procedure. */
579 gdbscm_is_procedure (SCM proc
)
581 return gdbscm_is_true (scm_procedure_p (proc
));
584 /* Same as xstrdup, but the string is allocated on the GC heap. */
587 gdbscm_gc_xstrdup (const char *str
)
589 size_t len
= strlen (str
);
590 char *result
= scm_gc_malloc_pointerless (len
+ 1, "gdbscm_gc_xstrdup");
592 strcpy (result
, str
);
596 /* Return a duplicate of ARGV living on the GC heap. */
599 gdbscm_gc_dup_argv (char **argv
)
605 for (len
= 0, string_space
= 0; argv
[len
] != NULL
; ++len
)
606 string_space
+= strlen (argv
[len
]) + 1;
608 /* Allocating "pointerless" works because the pointers are all
609 self-contained within the object. */
610 result
= scm_gc_malloc_pointerless (((len
+ 1) * sizeof (char *))
611 + string_space
, "parameter enum list");
612 p
= (char *) &result
[len
+ 1];
614 for (i
= 0; i
< len
; ++i
)
622 return (const char * const *) result
;
625 /* Return non-zero if the version of Guile being used it at least
626 MAJOR.MINOR.MICRO. */
629 gdbscm_guile_version_is_at_least (int major
, int minor
, int micro
)
631 if (major
> gdbscm_guile_major_version
)
633 if (major
< gdbscm_guile_major_version
)
635 if (minor
> gdbscm_guile_minor_version
)
637 if (minor
< gdbscm_guile_minor_version
)
639 if (micro
> gdbscm_guile_micro_version
)