GDB (xrefs)
scm-utils.c
Go to the documentation of this file.
1 /* General utility routines for GDB/Scheme code.
2 
3  Copyright (C) 2014-2015 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 "guile-internal.h"
25 
26 /* Define VARIABLES in the gdb module. */
27 
28 void
29 gdbscm_define_variables (const scheme_variable *variables, int is_public)
30 {
31  const scheme_variable *sv;
32 
33  for (sv = variables; sv->name != NULL; ++sv)
34  {
35  scm_c_define (sv->name, sv->value);
36  if (is_public)
37  scm_c_export (sv->name, NULL);
38  }
39 }
40 
41 /* Define FUNCTIONS in the gdb module. */
42 
43 void
44 gdbscm_define_functions (const scheme_function *functions, int is_public)
45 {
46  const scheme_function *sf;
47 
48  for (sf = functions; sf->name != NULL; ++sf)
49  {
50  SCM proc = scm_c_define_gsubr (sf->name, sf->required, sf->optional,
51  sf->rest, sf->func);
52 
53  scm_set_procedure_property_x (proc, gdbscm_documentation_symbol,
55  if (is_public)
56  scm_c_export (sf->name, NULL);
57  }
58 }
59 
60 /* Define CONSTANTS in the gdb module. */
61 
62 void
64  int is_public)
65 {
66  const scheme_integer_constant *sc;
67 
68  for (sc = constants; sc->name != NULL; ++sc)
69  {
70  scm_c_define (sc->name, scm_from_int (sc->value));
71  if (is_public)
72  scm_c_export (sc->name, NULL);
73  }
74 }
75 
76 /* scm_printf, alas it doesn't exist. */
77 
78 void
79 gdbscm_printf (SCM port, const char *format, ...)
80 {
81  va_list args;
82  char *string;
83 
84  va_start (args, format);
85  string = xstrvprintf (format, args);
86  va_end (args);
87  scm_puts (string, port);
88  xfree (string);
89 }
90 
91 /* Utility for calling from gdb to "display" an SCM object. */
92 
93 void
95 {
96  SCM port = scm_current_output_port ();
97 
98  scm_display (obj, port);
99  scm_newline (port);
100  scm_force_output (port);
101 }
102 
103 /* Utility for calling from gdb to "write" an SCM object. */
104 
105 void
107 {
108  SCM port = scm_current_output_port ();
109 
110  scm_write (obj, port);
111  scm_newline (port);
112  scm_force_output (port);
113 }
114 
115 /* Subroutine of gdbscm_parse_function_args to simplify it.
116  Return the number of keyword arguments. */
117 
118 static int
119 count_keywords (const SCM *keywords)
120 {
121  int i;
122 
123  if (keywords == NULL)
124  return 0;
125  for (i = 0; keywords[i] != SCM_BOOL_F; ++i)
126  continue;
127 
128  return i;
129 }
130 
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. */
134 
135 static int
136 validate_arg_format (const char *format)
137 {
138  const char *p;
139  int length = strlen (format);
140  int optional_position = -1;
141  int keyword_position = -1;
142  int dot_seen = 0;
143 
144  gdb_assert (length > 0);
145 
146  for (p = format; *p != '\0'; ++p)
147  {
148  switch (*p)
149  {
150  case 's':
151  case 't':
152  case 'i':
153  case 'u':
154  case 'l':
155  case 'n':
156  case 'L':
157  case 'U':
158  case 'O':
159  break;
160  case '|':
161  gdb_assert (keyword_position < 0);
162  gdb_assert (optional_position < 0);
163  optional_position = p - format;
164  break;
165  case '#':
166  gdb_assert (keyword_position < 0);
167  keyword_position = p - format;
168  break;
169  case '.':
170  gdb_assert (p[1] == '\0');
171  dot_seen = 1;
172  break;
173  default:
174  gdb_assert_not_reached ("invalid argument format character");
175  }
176  }
177 
178  return dot_seen;
179 }
180 
181 /* Our version of SCM_ASSERT_TYPE that calls gdbscm_make_type_error. */
182 #define CHECK_TYPE(ok, arg, position, func_name, expected_type) \
183  do { \
184  if (!(ok)) \
185  { \
186  return gdbscm_make_type_error ((func_name), (position), (arg), \
187  (expected_type)); \
188  } \
189  } while (0)
190 
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. */
195 
196 static SCM
197 extract_arg (char format_char, SCM arg, void *argp,
198  const char *func_name, int position)
199 {
200  switch (format_char)
201  {
202  case 's':
203  {
204  char **arg_ptr = argp;
205 
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);
209  break;
210  }
211  case 't':
212  {
213  int *arg_ptr = argp;
214 
215  /* While in Scheme, anything non-#f is "true", we're strict. */
216  CHECK_TYPE (gdbscm_is_bool (arg), arg, position, func_name,
217  _("boolean"));
218  *arg_ptr = gdbscm_is_true (arg);
219  break;
220  }
221  case 'i':
222  {
223  int *arg_ptr = argp;
224 
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);
228  break;
229  }
230  case 'u':
231  {
232  int *arg_ptr = argp;
233 
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);
237  break;
238  }
239  case 'l':
240  {
241  long *arg_ptr = argp;
242 
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);
246  break;
247  }
248  case 'n':
249  {
250  unsigned long *arg_ptr = argp;
251 
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);
255  break;
256  }
257  case 'L':
258  {
259  LONGEST *arg_ptr = argp;
260 
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);
264  break;
265  }
266  case 'U':
267  {
268  ULONGEST *arg_ptr = argp;
269 
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);
273  break;
274  }
275  case 'O':
276  {
277  SCM *arg_ptr = argp;
278 
279  *arg_ptr = arg;
280  break;
281  }
282  default:
283  gdb_assert_not_reached ("invalid argument format character");
284  }
285 
286  return SCM_BOOL_F;
287 }
288 
289 #undef CHECK_TYPE
290 
291 /* Look up KEYWORD in KEYWORD_LIST.
292  The result is the index of the keyword in the list or -1 if not found. */
293 
294 static int
295 lookup_keyword (const SCM *keyword_list, SCM keyword)
296 {
297  int i = 0;
298 
299  while (keyword_list[i] != SCM_BOOL_F)
300  {
301  if (scm_is_eq (keyword_list[i], keyword))
302  return i;
303  ++i;
304  }
305 
306  return -1;
307 }
308 
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.
313 
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.
316 
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.
320 
321  KEYWORDS may be NULL if there are no keywords.
322 
323  FORMAT:
324  s - string -> char *, malloc'd
325  t - boolean (gdb uses "t", for biT?) -> int
326  i - int
327  u - unsigned int
328  l - long
329  n - unsigned long
330  L - longest
331  U - unsigned longest
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
336 
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.
343 
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.
347 
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 }
354 
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".
360 
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.
366 
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
369  removed).
370 
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. */
375 
376 void
377 gdbscm_parse_function_args (const char *func_name,
378  int beginning_arg_pos,
379  const SCM *keywords,
380  const char *format, ...)
381 {
382  va_list args;
383  const char *p;
384  int i, have_rest, num_keywords, length, position;
385  int have_optional = 0;
386  SCM status;
387  SCM rest = SCM_EOL;
388  /* Keep track of malloc'd strings. We need to free them upon error. */
389  VEC (char_ptr) *allocated_strings = NULL;
390  char *ptr;
391 
392  have_rest = validate_arg_format (format);
393  num_keywords = count_keywords (keywords);
394 
395  va_start (args, format);
396 
397  p = format;
398  position = beginning_arg_pos;
399 
400  /* Process required, optional arguments. */
401 
402  while (*p && *p != '#' && *p != '.')
403  {
404  SCM arg;
405  void *arg_ptr;
406 
407  if (*p == '|')
408  {
409  have_optional = 1;
410  ++p;
411  continue;
412  }
413 
414  arg = va_arg (args, SCM);
415  if (!have_optional || !SCM_UNBNDP (arg))
416  {
417  arg_ptr = va_arg (args, void *);
418  status = extract_arg (*p, arg, arg_ptr, func_name, position);
419  if (!gdbscm_is_false (status))
420  goto fail;
421  if (*p == 's')
422  VEC_safe_push (char_ptr, allocated_strings, *(char **) arg_ptr);
423  }
424  ++p;
425  ++position;
426  }
427 
428  /* Process keyword arguments. */
429 
430  if (have_rest || num_keywords > 0)
431  rest = va_arg (args, SCM);
432 
433  if (num_keywords > 0)
434  {
435  SCM *keyword_args = (SCM *) alloca (num_keywords * sizeof (SCM));
436  int *keyword_positions = (int *) alloca (num_keywords * sizeof (int));
437 
438  gdb_assert (*p == '#');
439  ++p;
440 
441  for (i = 0; i < num_keywords; ++i)
442  {
443  keyword_args[i] = SCM_UNSPECIFIED;
444  keyword_positions[i] = -1;
445  }
446 
447  while (scm_is_pair (rest)
448  && scm_is_keyword (scm_car (rest)))
449  {
450  SCM keyword = scm_car (rest);
451 
452  i = lookup_keyword (keywords, keyword);
453  if (i < 0)
454  {
455  status = gdbscm_make_error (scm_arg_type_key, func_name,
456  _("Unrecognized keyword: ~a"),
457  scm_list_1 (keyword), keyword);
458  goto fail;
459  }
460  if (!scm_is_pair (scm_cdr (rest)))
461  {
462  status = gdbscm_make_error
463  (scm_arg_type_key, func_name,
464  _("Missing value for keyword argument"),
465  scm_list_1 (keyword), keyword);
466  goto fail;
467  }
468  keyword_args[i] = scm_cadr (rest);
469  keyword_positions[i] = position + 1;
470  rest = scm_cddr (rest);
471  position += 2;
472  }
473 
474  for (i = 0; i < num_keywords; ++i)
475  {
476  int *arg_pos_ptr = va_arg (args, int *);
477  void *arg_ptr = va_arg (args, void *);
478  SCM arg = keyword_args[i];
479 
480  if (! scm_is_eq (arg, SCM_UNSPECIFIED))
481  {
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))
486  goto fail;
487  if (p[i] == 's')
488  {
489  VEC_safe_push (char_ptr, allocated_strings,
490  *(char **) arg_ptr);
491  }
492  }
493  }
494  }
495 
496  /* Process "rest" arguments. */
497 
498  if (have_rest)
499  {
500  if (num_keywords > 0)
501  {
502  SCM *rest_ptr = va_arg (args, SCM *);
503 
504  *rest_ptr = rest;
505  }
506  }
507  else
508  {
509  if (! scm_is_null (rest))
510  {
511  status = gdbscm_make_error (scm_args_number_key, func_name,
512  _("Too many arguments"),
513  SCM_EOL, SCM_BOOL_F);
514  goto fail;
515  }
516  }
517 
518  va_end (args);
519  VEC_free (char_ptr, allocated_strings);
520  return;
521 
522  fail:
523  va_end (args);
524  for (i = 0; VEC_iterate (char_ptr, allocated_strings, i, ptr); ++i)
525  xfree (ptr);
526  VEC_free (char_ptr, allocated_strings);
527  gdbscm_throw (status);
528 }
529 
530 /* Return longest L as a scheme object. */
531 
532 SCM
534 {
535  return scm_from_int64 (l);
536 }
537 
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). */
542 
543 LONGEST
545 {
546  return scm_to_int64 (l);
547 }
548 
549 /* Return unsigned longest L as a scheme object. */
550 
551 SCM
553 {
554  return scm_from_uint64 (l);
555 }
556 
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). */
561 
562 ULONGEST
564 {
565  return scm_to_uint64 (u);
566 }
567 
568 /* Same as scm_dynwind_free, but uses xfree. */
569 
570 void
572 {
573  scm_dynwind_unwind_handler (xfree, ptr, SCM_F_WIND_EXPLICITLY);
574 }
575 
576 /* Return non-zero if PROC is a procedure. */
577 
578 int
580 {
581  return gdbscm_is_true (scm_procedure_p (proc));
582 }
583 
584 /* Same as xstrdup, but the string is allocated on the GC heap. */
585 
586 char *
587 gdbscm_gc_xstrdup (const char *str)
588 {
589  size_t len = strlen (str);
590  char *result = scm_gc_malloc_pointerless (len + 1, "gdbscm_gc_xstrdup");
591 
592  strcpy (result, str);
593  return result;
594 }
595 
596 /* Return a duplicate of ARGV living on the GC heap. */
597 
598 const char * const *
599 gdbscm_gc_dup_argv (char **argv)
600 {
601  int i, len;
602  size_t string_space;
603  char *p, **result;
604 
605  for (len = 0, string_space = 0; argv[len] != NULL; ++len)
606  string_space += strlen (argv[len]) + 1;
607 
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];
613 
614  for (i = 0; i < len; ++i)
615  {
616  result[i] = p;
617  strcpy (p, argv[i]);
618  p += strlen (p) + 1;
619  }
620  result[i] = NULL;
621 
622  return (const char * const *) result;
623 }
624 
625 /* Return non-zero if the version of Guile being used it at least
626  MAJOR.MINOR.MICRO. */
627 
628 int
629 gdbscm_guile_version_is_at_least (int major, int minor, int micro)
630 {
631  if (major > gdbscm_guile_major_version)
632  return 0;
633  if (major < gdbscm_guile_major_version)
634  return 1;
635  if (minor > gdbscm_guile_minor_version)
636  return 0;
637  if (minor < gdbscm_guile_minor_version)
638  return 1;
639  if (micro > gdbscm_guile_micro_version)
640  return 0;
641  return 1;
642 }
const char * string
Definition: signals.c:50
#define CHECK_TYPE(ok, arg, position, func_name, expected_type)
Definition: scm-utils.c:182
void gdbscm_dynwind_xfree(void *ptr)
Definition: scm-utils.c:571
int gdbscm_guile_major_version
Definition: guile.c:45
void gdbscm_parse_function_args(const char *func_name, int beginning_arg_pos, const SCM *keywords, const char *format,...)
Definition: scm-utils.c:377
SCM gdbscm_scm_from_longest(LONGEST l)
Definition: scm-utils.c:533
void xfree(void *)
Definition: common-utils.c:97
static int validate_arg_format(const char *format)
Definition: scm-utils.c:136
const char * name
char * xstrvprintf(const char *format, va_list ap)
Definition: common-utils.c:119
#define INT_MAX
Definition: defs.h:509
static int lookup_keyword(const SCM *keyword_list, SCM keyword)
Definition: scm-utils.c:295
#define ULONG_MAX
Definition: defs.h:517
#define INT_MIN
Definition: defs.h:513
char * gdbscm_scm_to_c_string(SCM string)
Definition: scm-string.c:55
void gdbscm_define_integer_constants(const scheme_integer_constant *constants, int is_public)
Definition: scm-utils.c:63
const char * doc_string
#define VEC_safe_push(T, V, O)
Definition: vec.h:260
#define gdbscm_is_bool(scm)
#define VEC(T)
Definition: vec.h:398
static int count_keywords(const SCM *keywords)
Definition: scm-utils.c:119
#define _(String)
Definition: gdb_locale.h:40
char * char_ptr
Definition: gdb_vecs.h:25
void gdbscm_define_variables(const scheme_variable *variables, int is_public)
Definition: scm-utils.c:29
#define gdbscm_is_true(scm)
char * gdbscm_gc_xstrdup(const char *str)
Definition: scm-utils.c:587
int gdbscm_guile_minor_version
Definition: guile.c:46
void gdbscm_define_functions(const scheme_function *functions, int is_public)
Definition: scm-utils.c:44
#define VEC_iterate(T, V, I, P)
Definition: vec.h:165
scm_t_subr func
Definition: gnu-nat.h:42
#define UINT_MAX
Definition: defs.h:505
SCM gdbscm_scm_from_c_string(const char *string)
Definition: scm-string.c:44
#define LONG_MAX
Definition: defs.h:521
#define gdbscm_is_false(scm)
mach_port_t mach_port_t name mach_port_t mach_port_t name error_t int status
Definition: gnu-nat.c:1816
#define gdb_assert_not_reached(message)
Definition: gdb_assert.h:56
void gdbscm_throw(SCM exception) ATTRIBUTE_NORETURN
#define gdb_assert(expr)
Definition: gdb_assert.h:33
const char *const * gdbscm_gc_dup_argv(char **argv)
Definition: scm-utils.c:599
void gdbscm_debug_display(SCM obj)
Definition: scm-utils.c:94
int gdbscm_guile_version_is_at_least(int major, int minor, int micro)
Definition: scm-utils.c:629
static SCM extract_arg(char format_char, SCM arg, void *argp, const char *func_name, int position)
Definition: scm-utils.c:197
void gdbscm_printf(SCM port, const char *format,...)
Definition: scm-utils.c:79
int gdbscm_is_procedure(SCM proc)
Definition: scm-utils.c:579
unsigned length
Definition: gdbtypes.h:807
const char * name
#define VEC_free(T, V)
Definition: vec.h:180
SCM gdbscm_documentation_symbol
SCM gdbscm_scm_from_ulongest(ULONGEST l)
Definition: scm-utils.c:552
unsigned long long ULONGEST
Definition: common-types.h:53
SCM gdbscm_make_error(SCM key, const char *subr, const char *message, SCM args, SCM data)
ULONGEST gdbscm_scm_to_ulongest(SCM u)
Definition: scm-utils.c:563
void gdbscm_debug_write(SCM obj)
Definition: scm-utils.c:106
int gdbscm_guile_micro_version
Definition: guile.c:47
long long LONGEST
Definition: common-types.h:52
const ULONGEST const LONGEST len
Definition: target.h:309
LONGEST gdbscm_scm_to_longest(SCM l)
Definition: scm-utils.c:544