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