Commit | Line | Data |
---|---|---|
ed3ef339 DE |
1 | /* General utility routines for GDB/Scheme code. |
2 | ||
32d0add0 | 3 | Copyright (C) 2014-2015 Free Software Foundation, Inc. |
ed3ef339 DE |
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" | |
ed3ef339 | 24 | #include <stdint.h> |
ed3ef339 DE |
25 | #include "guile-internal.h" |
26 | ||
27 | /* Define VARIABLES in the gdb module. */ | |
28 | ||
29 | void | |
30 | gdbscm_define_variables (const scheme_variable *variables, int public) | |
31 | { | |
32 | const scheme_variable *sv; | |
33 | ||
34 | for (sv = variables; sv->name != NULL; ++sv) | |
35 | { | |
36 | scm_c_define (sv->name, sv->value); | |
37 | if (public) | |
38 | scm_c_export (sv->name, NULL); | |
39 | } | |
40 | } | |
41 | ||
42 | /* Define FUNCTIONS in the gdb module. */ | |
43 | ||
44 | void | |
45 | gdbscm_define_functions (const scheme_function *functions, int public) | |
46 | { | |
47 | const scheme_function *sf; | |
48 | ||
49 | for (sf = functions; sf->name != NULL; ++sf) | |
50 | { | |
51 | SCM proc = scm_c_define_gsubr (sf->name, sf->required, sf->optional, | |
52 | sf->rest, sf->func); | |
53 | ||
54 | scm_set_procedure_property_x (proc, gdbscm_documentation_symbol, | |
55 | gdbscm_scm_from_c_string (sf->doc_string)); | |
56 | if (public) | |
57 | scm_c_export (sf->name, NULL); | |
58 | } | |
59 | } | |
60 | ||
61 | /* Define CONSTANTS in the gdb module. */ | |
62 | ||
63 | void | |
64 | gdbscm_define_integer_constants (const scheme_integer_constant *constants, | |
65 | int public) | |
66 | { | |
67 | const scheme_integer_constant *sc; | |
68 | ||
69 | for (sc = constants; sc->name != NULL; ++sc) | |
70 | { | |
71 | scm_c_define (sc->name, scm_from_int (sc->value)); | |
72 | if (public) | |
73 | scm_c_export (sc->name, NULL); | |
74 | } | |
75 | } | |
76 | \f | |
77 | /* scm_printf, alas it doesn't exist. */ | |
78 | ||
79 | void | |
80 | gdbscm_printf (SCM port, const char *format, ...) | |
81 | { | |
82 | va_list args; | |
83 | char *string; | |
84 | ||
85 | va_start (args, format); | |
86 | string = xstrvprintf (format, args); | |
87 | va_end (args); | |
88 | scm_puts (string, port); | |
89 | xfree (string); | |
90 | } | |
91 | ||
92 | /* Utility for calling from gdb to "display" an SCM object. */ | |
93 | ||
94 | void | |
95 | gdbscm_debug_display (SCM obj) | |
96 | { | |
97 | SCM port = scm_current_output_port (); | |
98 | ||
99 | scm_display (obj, port); | |
100 | scm_newline (port); | |
101 | scm_force_output (port); | |
102 | } | |
103 | ||
104 | /* Utility for calling from gdb to "write" an SCM object. */ | |
105 | ||
106 | void | |
107 | gdbscm_debug_write (SCM obj) | |
108 | { | |
109 | SCM port = scm_current_output_port (); | |
110 | ||
111 | scm_write (obj, port); | |
112 | scm_newline (port); | |
113 | scm_force_output (port); | |
114 | } | |
115 | \f | |
116 | /* Subroutine of gdbscm_parse_function_args to simplify it. | |
117 | Return the number of keyword arguments. */ | |
118 | ||
119 | static int | |
120 | count_keywords (const SCM *keywords) | |
121 | { | |
122 | int i; | |
123 | ||
124 | if (keywords == NULL) | |
125 | return 0; | |
126 | for (i = 0; keywords[i] != SCM_BOOL_F; ++i) | |
127 | continue; | |
128 | ||
129 | return i; | |
130 | } | |
131 | ||
132 | /* Subroutine of gdbscm_parse_function_args to simplify it. | |
133 | Validate an argument format string. | |
134 | The result is a boolean indicating if "." was seen. */ | |
135 | ||
136 | static int | |
137 | validate_arg_format (const char *format) | |
138 | { | |
139 | const char *p; | |
140 | int length = strlen (format); | |
141 | int optional_position = -1; | |
142 | int keyword_position = -1; | |
143 | int dot_seen = 0; | |
144 | ||
145 | gdb_assert (length > 0); | |
146 | ||
147 | for (p = format; *p != '\0'; ++p) | |
148 | { | |
149 | switch (*p) | |
150 | { | |
151 | case 's': | |
152 | case 't': | |
153 | case 'i': | |
154 | case 'u': | |
155 | case 'l': | |
156 | case 'n': | |
157 | case 'L': | |
158 | case 'U': | |
159 | case 'O': | |
160 | break; | |
161 | case '|': | |
162 | gdb_assert (keyword_position < 0); | |
163 | gdb_assert (optional_position < 0); | |
164 | optional_position = p - format; | |
165 | break; | |
166 | case '#': | |
167 | gdb_assert (keyword_position < 0); | |
168 | keyword_position = p - format; | |
169 | break; | |
170 | case '.': | |
171 | gdb_assert (p[1] == '\0'); | |
172 | dot_seen = 1; | |
173 | break; | |
174 | default: | |
175 | gdb_assert_not_reached ("invalid argument format character"); | |
176 | } | |
177 | } | |
178 | ||
179 | return dot_seen; | |
180 | } | |
181 | ||
182 | /* Our version of SCM_ASSERT_TYPE that calls gdbscm_make_type_error. */ | |
183 | #define CHECK_TYPE(ok, arg, position, func_name, expected_type) \ | |
184 | do { \ | |
185 | if (!(ok)) \ | |
186 | { \ | |
187 | return gdbscm_make_type_error ((func_name), (position), (arg), \ | |
188 | (expected_type)); \ | |
189 | } \ | |
190 | } while (0) | |
191 | ||
192 | /* Subroutine of gdbscm_parse_function_args to simplify it. | |
193 | Check the type of ARG against FORMAT_CHAR and extract the value. | |
194 | POSITION is the position of ARG in the argument list. | |
195 | The result is #f upon success or a <gdb:exception> object. */ | |
196 | ||
197 | static SCM | |
198 | extract_arg (char format_char, SCM arg, void *argp, | |
199 | const char *func_name, int position) | |
200 | { | |
201 | switch (format_char) | |
202 | { | |
203 | case 's': | |
204 | { | |
205 | char **arg_ptr = argp; | |
206 | ||
207 | CHECK_TYPE (gdbscm_is_true (scm_string_p (arg)), arg, position, | |
208 | func_name, _("string")); | |
209 | *arg_ptr = gdbscm_scm_to_c_string (arg); | |
210 | break; | |
211 | } | |
212 | case 't': | |
213 | { | |
214 | int *arg_ptr = argp; | |
215 | ||
216 | /* While in Scheme, anything non-#f is "true", we're strict. */ | |
217 | CHECK_TYPE (gdbscm_is_bool (arg), arg, position, func_name, | |
218 | _("boolean")); | |
219 | *arg_ptr = gdbscm_is_true (arg); | |
220 | break; | |
221 | } | |
222 | case 'i': | |
223 | { | |
224 | int *arg_ptr = argp; | |
225 | ||
226 | CHECK_TYPE (scm_is_signed_integer (arg, INT_MIN, INT_MAX), | |
227 | arg, position, func_name, _("int")); | |
228 | *arg_ptr = scm_to_int (arg); | |
229 | break; | |
230 | } | |
231 | case 'u': | |
232 | { | |
233 | int *arg_ptr = argp; | |
234 | ||
235 | CHECK_TYPE (scm_is_unsigned_integer (arg, 0, UINT_MAX), | |
236 | arg, position, func_name, _("unsigned int")); | |
237 | *arg_ptr = scm_to_uint (arg); | |
238 | break; | |
239 | } | |
240 | case 'l': | |
241 | { | |
242 | long *arg_ptr = argp; | |
243 | ||
244 | CHECK_TYPE (scm_is_signed_integer (arg, LONG_MIN, LONG_MAX), | |
245 | arg, position, func_name, _("long")); | |
246 | *arg_ptr = scm_to_long (arg); | |
247 | break; | |
248 | } | |
249 | case 'n': | |
250 | { | |
251 | unsigned long *arg_ptr = argp; | |
252 | ||
253 | CHECK_TYPE (scm_is_unsigned_integer (arg, 0, ULONG_MAX), | |
254 | arg, position, func_name, _("unsigned long")); | |
255 | *arg_ptr = scm_to_ulong (arg); | |
256 | break; | |
257 | } | |
258 | case 'L': | |
259 | { | |
260 | LONGEST *arg_ptr = argp; | |
261 | ||
262 | CHECK_TYPE (scm_is_signed_integer (arg, INT64_MIN, INT64_MAX), | |
263 | arg, position, func_name, _("LONGEST")); | |
264 | *arg_ptr = gdbscm_scm_to_longest (arg); | |
265 | break; | |
266 | } | |
267 | case 'U': | |
268 | { | |
269 | ULONGEST *arg_ptr = argp; | |
270 | ||
271 | CHECK_TYPE (scm_is_unsigned_integer (arg, 0, UINT64_MAX), | |
272 | arg, position, func_name, _("ULONGEST")); | |
273 | *arg_ptr = gdbscm_scm_to_ulongest (arg); | |
274 | break; | |
275 | } | |
276 | case 'O': | |
277 | { | |
278 | SCM *arg_ptr = argp; | |
279 | ||
280 | *arg_ptr = arg; | |
281 | break; | |
282 | } | |
283 | default: | |
284 | gdb_assert_not_reached ("invalid argument format character"); | |
285 | } | |
286 | ||
287 | return SCM_BOOL_F; | |
288 | } | |
289 | ||
290 | #undef CHECK_TYPE | |
291 | ||
292 | /* Look up KEYWORD in KEYWORD_LIST. | |
293 | The result is the index of the keyword in the list or -1 if not found. */ | |
294 | ||
295 | static int | |
296 | lookup_keyword (const SCM *keyword_list, SCM keyword) | |
297 | { | |
298 | int i = 0; | |
299 | ||
300 | while (keyword_list[i] != SCM_BOOL_F) | |
301 | { | |
302 | if (scm_is_eq (keyword_list[i], keyword)) | |
303 | return i; | |
304 | ++i; | |
305 | } | |
306 | ||
307 | return -1; | |
308 | } | |
309 | ||
310 | /* Utility to parse required, optional, and keyword arguments to Scheme | |
311 | functions. Modelled on PyArg_ParseTupleAndKeywords, but no attempt is made | |
312 | at similarity or functionality. | |
313 | There is no result, if there's an error a Scheme exception is thrown. | |
314 | ||
315 | Guile provides scm_c_bind_keyword_arguments, and feel free to use it. | |
316 | This is for times when we want a bit more parsing. | |
317 | ||
318 | BEGINNING_ARG_POS is the position of the first argument passed to this | |
319 | routine. It should be one of the SCM_ARGn values. It could be > SCM_ARG1 | |
320 | if the caller chooses not to parse one or more required arguments. | |
321 | ||
322 | KEYWORDS may be NULL if there are no keywords. | |
323 | ||
324 | FORMAT: | |
325 | s - string -> char *, malloc'd | |
326 | t - boolean (gdb uses "t", for biT?) -> int | |
327 | i - int | |
328 | u - unsigned int | |
329 | l - long | |
330 | n - unsigned long | |
331 | L - longest | |
332 | U - unsigned longest | |
333 | O - random scheme object | |
334 | | - indicates the next set is for optional arguments | |
335 | # - indicates the next set is for keyword arguments (must follow |) | |
336 | . - indicates "rest" arguments are present, this character must appear last | |
337 | ||
338 | FORMAT must match the definition from scm_c_{make,define}_gsubr. | |
339 | Required and optional arguments appear in order in the format string. | |
340 | Afterwards, keyword-based arguments are processed. There must be as many | |
341 | remaining characters in the format string as their are keywords. | |
342 | Except for "|#.", the number of characters in the format string must match | |
343 | #required + #optional + #keywords. | |
344 | ||
345 | The function is required to be defined in a compatible manner: | |
346 | #required-args and #optional-arguments must match, and rest-arguments | |
347 | must be specified if keyword args are desired, and/or regular "rest" args. | |
348 | ||
349 | Example: For this function, | |
350 | scm_c_define_gsubr ("execute", 2, 3, 1, foo); | |
351 | the format string + keyword list could be any of: | |
352 | 1) "ss|ttt#tt", { "key1", "key2", NULL } | |
353 | 2) "ss|ttt.", { NULL } | |
354 | 3) "ss|ttt#t.", { "key1", NULL } | |
355 | ||
356 | For required and optional args pass the SCM of the argument, and a | |
357 | pointer to the value to hold the parsed result (type depends on format | |
358 | char). After that pass the SCM containing the "rest" arguments followed | |
359 | by pointers to values to hold parsed keyword arguments, and if specified | |
360 | a pointer to hold the remaining contents of "rest". | |
361 | ||
362 | For keyword arguments pass two pointers: the first is a pointer to an int | |
363 | that will contain the position of the argument in the arg list, and the | |
364 | second will contain result of processing the argument. The int pointed | |
365 | to by the first value should be initialized to -1. It can then be used | |
366 | to tell whether the keyword was present. | |
367 | ||
368 | If both keyword and rest arguments are present, the caller must pass a | |
369 | pointer to contain the new value of rest (after keyword args have been | |
370 | removed). | |
371 | ||
372 | There's currently no way, that I know of, to specify default values for | |
373 | optional arguments in C-provided functions. At the moment they're a | |
374 | work-in-progress. The caller should test SCM_UNBNDP for each optional | |
375 | argument. Unbound optional arguments are ignored. */ | |
376 | ||
377 | void | |
378 | gdbscm_parse_function_args (const char *func_name, | |
379 | int beginning_arg_pos, | |
380 | const SCM *keywords, | |
381 | const char *format, ...) | |
382 | { | |
383 | va_list args; | |
384 | const char *p; | |
385 | int i, have_rest, num_keywords, length, position; | |
386 | int have_optional = 0; | |
387 | SCM status; | |
388 | SCM rest = SCM_EOL; | |
389 | /* Keep track of malloc'd strings. We need to free them upon error. */ | |
390 | VEC (char_ptr) *allocated_strings = NULL; | |
391 | char *ptr; | |
392 | ||
393 | have_rest = validate_arg_format (format); | |
394 | num_keywords = count_keywords (keywords); | |
395 | ||
396 | va_start (args, format); | |
397 | ||
398 | p = format; | |
399 | position = beginning_arg_pos; | |
400 | ||
401 | /* Process required, optional arguments. */ | |
402 | ||
403 | while (*p && *p != '#' && *p != '.') | |
404 | { | |
405 | SCM arg; | |
406 | void *arg_ptr; | |
407 | ||
408 | if (*p == '|') | |
409 | { | |
410 | have_optional = 1; | |
411 | ++p; | |
412 | continue; | |
413 | } | |
414 | ||
415 | arg = va_arg (args, SCM); | |
416 | if (!have_optional || !SCM_UNBNDP (arg)) | |
417 | { | |
418 | arg_ptr = va_arg (args, void *); | |
419 | status = extract_arg (*p, arg, arg_ptr, func_name, position); | |
420 | if (!gdbscm_is_false (status)) | |
421 | goto fail; | |
422 | if (*p == 's') | |
423 | VEC_safe_push (char_ptr, allocated_strings, *(char **) arg_ptr); | |
424 | } | |
425 | ++p; | |
426 | ++position; | |
427 | } | |
428 | ||
429 | /* Process keyword arguments. */ | |
430 | ||
431 | if (have_rest || num_keywords > 0) | |
432 | rest = va_arg (args, SCM); | |
433 | ||
434 | if (num_keywords > 0) | |
435 | { | |
436 | SCM *keyword_args = (SCM *) alloca (num_keywords * sizeof (SCM)); | |
437 | int *keyword_positions = (int *) alloca (num_keywords * sizeof (int)); | |
438 | ||
439 | gdb_assert (*p == '#'); | |
440 | ++p; | |
441 | ||
442 | for (i = 0; i < num_keywords; ++i) | |
443 | { | |
444 | keyword_args[i] = SCM_UNSPECIFIED; | |
445 | keyword_positions[i] = -1; | |
446 | } | |
447 | ||
448 | while (scm_is_pair (rest) | |
449 | && scm_is_keyword (scm_car (rest))) | |
450 | { | |
451 | SCM keyword = scm_car (rest); | |
452 | ||
453 | i = lookup_keyword (keywords, keyword); | |
454 | if (i < 0) | |
455 | { | |
456 | status = gdbscm_make_error (scm_arg_type_key, func_name, | |
457 | _("Unrecognized keyword: ~a"), | |
458 | scm_list_1 (keyword), keyword); | |
459 | goto fail; | |
460 | } | |
461 | if (!scm_is_pair (scm_cdr (rest))) | |
462 | { | |
463 | status = gdbscm_make_error | |
464 | (scm_arg_type_key, func_name, | |
465 | _("Missing value for keyword argument"), | |
466 | scm_list_1 (keyword), keyword); | |
467 | goto fail; | |
468 | } | |
469 | keyword_args[i] = scm_cadr (rest); | |
470 | keyword_positions[i] = position + 1; | |
471 | rest = scm_cddr (rest); | |
472 | position += 2; | |
473 | } | |
474 | ||
475 | for (i = 0; i < num_keywords; ++i) | |
476 | { | |
477 | int *arg_pos_ptr = va_arg (args, int *); | |
478 | void *arg_ptr = va_arg (args, void *); | |
479 | SCM arg = keyword_args[i]; | |
480 | ||
481 | if (! scm_is_eq (arg, SCM_UNSPECIFIED)) | |
482 | { | |
483 | *arg_pos_ptr = keyword_positions[i]; | |
484 | status = extract_arg (p[i], arg, arg_ptr, func_name, | |
485 | keyword_positions[i]); | |
486 | if (!gdbscm_is_false (status)) | |
487 | goto fail; | |
488 | if (p[i] == 's') | |
489 | { | |
490 | VEC_safe_push (char_ptr, allocated_strings, | |
491 | *(char **) arg_ptr); | |
492 | } | |
493 | } | |
494 | } | |
495 | } | |
496 | ||
497 | /* Process "rest" arguments. */ | |
498 | ||
499 | if (have_rest) | |
500 | { | |
501 | if (num_keywords > 0) | |
502 | { | |
503 | SCM *rest_ptr = va_arg (args, SCM *); | |
504 | ||
505 | *rest_ptr = rest; | |
506 | } | |
507 | } | |
508 | else | |
509 | { | |
510 | if (! scm_is_null (rest)) | |
511 | { | |
512 | status = gdbscm_make_error (scm_args_number_key, func_name, | |
513 | _("Too many arguments"), | |
514 | SCM_EOL, SCM_BOOL_F); | |
515 | goto fail; | |
516 | } | |
517 | } | |
518 | ||
519 | va_end (args); | |
520 | VEC_free (char_ptr, allocated_strings); | |
521 | return; | |
522 | ||
523 | fail: | |
524 | va_end (args); | |
525 | for (i = 0; VEC_iterate (char_ptr, allocated_strings, i, ptr); ++i) | |
526 | xfree (ptr); | |
527 | VEC_free (char_ptr, allocated_strings); | |
528 | gdbscm_throw (status); | |
529 | } | |
530 | \f | |
531 | /* Return longest L as a scheme object. */ | |
532 | ||
533 | SCM | |
534 | gdbscm_scm_from_longest (LONGEST l) | |
535 | { | |
536 | return scm_from_int64 (l); | |
537 | } | |
538 | ||
539 | /* Convert scheme object L to LONGEST. | |
540 | It is an error to call this if L is not an integer in range of LONGEST. | |
541 | (because the underlying Scheme function will thrown an exception, | |
542 | which is not part of our contract with the caller). */ | |
543 | ||
544 | LONGEST | |
545 | gdbscm_scm_to_longest (SCM l) | |
546 | { | |
547 | return scm_to_int64 (l); | |
548 | } | |
549 | ||
550 | /* Return unsigned longest L as a scheme object. */ | |
551 | ||
552 | SCM | |
553 | gdbscm_scm_from_ulongest (ULONGEST l) | |
554 | { | |
555 | return scm_from_uint64 (l); | |
556 | } | |
557 | ||
558 | /* Convert scheme object U to ULONGEST. | |
559 | It is an error to call this if U is not an integer in range of ULONGEST | |
560 | (because the underlying Scheme function will thrown an exception, | |
561 | which is not part of our contract with the caller). */ | |
562 | ||
563 | ULONGEST | |
564 | gdbscm_scm_to_ulongest (SCM u) | |
565 | { | |
566 | return scm_to_uint64 (u); | |
567 | } | |
568 | ||
569 | /* Same as scm_dynwind_free, but uses xfree. */ | |
570 | ||
571 | void | |
572 | gdbscm_dynwind_xfree (void *ptr) | |
573 | { | |
574 | scm_dynwind_unwind_handler (xfree, ptr, SCM_F_WIND_EXPLICITLY); | |
575 | } | |
576 | ||
577 | /* Return non-zero if PROC is a procedure. */ | |
578 | ||
579 | int | |
580 | gdbscm_is_procedure (SCM proc) | |
581 | { | |
582 | return gdbscm_is_true (scm_procedure_p (proc)); | |
583 | } | |
e698b8c4 DE |
584 | |
585 | /* Same as xstrdup, but the string is allocated on the GC heap. */ | |
586 | ||
587 | char * | |
588 | gdbscm_gc_xstrdup (const char *str) | |
589 | { | |
590 | size_t len = strlen (str); | |
591 | char *result = scm_gc_malloc_pointerless (len + 1, "gdbscm_gc_xstrdup"); | |
592 | ||
593 | strcpy (result, str); | |
594 | return result; | |
595 | } | |
06eb1586 DE |
596 | |
597 | /* Return a duplicate of ARGV living on the GC heap. */ | |
598 | ||
599 | const char * const * | |
600 | gdbscm_gc_dup_argv (char **argv) | |
601 | { | |
602 | int i, len; | |
603 | size_t string_space; | |
604 | char *p, **result; | |
605 | ||
606 | for (len = 0, string_space = 0; argv[len] != NULL; ++len) | |
607 | string_space += strlen (argv[len]) + 1; | |
608 | ||
609 | /* Allocating "pointerless" works because the pointers are all | |
610 | self-contained within the object. */ | |
611 | result = scm_gc_malloc_pointerless (((len + 1) * sizeof (char *)) | |
612 | + string_space, "parameter enum list"); | |
613 | p = (char *) &result[len + 1]; | |
614 | ||
615 | for (i = 0; i < len; ++i) | |
616 | { | |
617 | result[i] = p; | |
618 | strcpy (p, argv[i]); | |
619 | p += strlen (p) + 1; | |
620 | } | |
621 | result[i] = NULL; | |
622 | ||
623 | return (const char * const *) result; | |
624 | } | |
d2929fdc DE |
625 | |
626 | /* Return non-zero if the version of Guile being used it at least | |
627 | MAJOR.MINOR.MICRO. */ | |
628 | ||
629 | int | |
630 | gdbscm_guile_version_is_at_least (int major, int minor, int micro) | |
631 | { | |
632 | if (major > gdbscm_guile_major_version) | |
633 | return 0; | |
634 | if (major < gdbscm_guile_major_version) | |
635 | return 1; | |
636 | if (minor > gdbscm_guile_minor_version) | |
637 | return 0; | |
638 | if (minor < gdbscm_guile_minor_version) | |
639 | return 1; | |
640 | if (micro > gdbscm_guile_micro_version) | |
641 | return 0; | |
642 | return 1; | |
643 | } |