projects / deliverable / binutils-gdb.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
reverse-finish: turn internal error into normal error
[deliverable/binutils-gdb.git] / gdb / guile / scm-math.c
CommitLineData
ed3ef339
DE		 1/* GDB/Scheme support for math operations on values.
2
3 Copyright (C) 2008-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 "arch-utils.h"
25#include "charset.h"
26#include "cp-abi.h"
27#include "doublest.h" /* Needed by dfp.h. */
28#include "expression.h" /* Needed by dfp.h. */
29#include "dfp.h"
30#include "gdb_assert.h"
31#include "symtab.h" /* Needed by language.h. */
32#include "language.h"
33#include "valprint.h"
34#include "value.h"
35#include "guile-internal.h"
36
37/* Note: Use target types here to remain consistent with the values system in
38 GDB (which uses target arithmetic). */
39
40enum valscm_unary_opcode
41{
42 VALSCM_NOT,
43 VALSCM_NEG,
44 VALSCM_NOP,
45 VALSCM_ABS,
46 /* Note: This is Scheme's "logical not", not GDB's.
47 GDB calls this UNOP_COMPLEMENT. */
48 VALSCM_LOGNOT
49};
50
51enum valscm_binary_opcode
52{
53 VALSCM_ADD,
54 VALSCM_SUB,
55 VALSCM_MUL,
56 VALSCM_DIV,
57 VALSCM_REM,
58 VALSCM_MOD,
59 VALSCM_POW,
60 VALSCM_LSH,
61 VALSCM_RSH,
62 VALSCM_MIN,
63 VALSCM_MAX,
64 VALSCM_BITAND,
65 VALSCM_BITOR,
66 VALSCM_BITXOR
67};
68
69/* If TYPE is a reference, return the target; otherwise return TYPE. */
70#define STRIP_REFERENCE(TYPE) \
71 ((TYPE_CODE (TYPE) == TYPE_CODE_REF) ? (TYPE_TARGET_TYPE (TYPE)) : (TYPE))
72
73/* Returns a value object which is the result of applying the operation
74 specified by OPCODE to the given argument.
75 If there's an error a Scheme exception is thrown. */
76
77static SCM
78vlscm_unop (enum valscm_unary_opcode opcode, SCM x, const char *func_name)
79{
80 struct gdbarch *gdbarch = get_current_arch ();
81 const struct language_defn *language = current_language;
82 struct value *arg1;
83 SCM result = SCM_BOOL_F;
84 struct value *res_val = NULL;
85 SCM except_scm;
86 struct cleanup *cleanups;
87 volatile struct gdb_exception except;
88
89 cleanups = make_cleanup_value_free_to_mark (value_mark ());
90
91 arg1 = vlscm_convert_value_from_scheme (func_name, SCM_ARG1, x,
92 &except_scm, gdbarch, language);
93 if (arg1 == NULL)
94 {
95 do_cleanups (cleanups);
96 gdbscm_throw (except_scm);
97 }
98
99 TRY_CATCH (except, RETURN_MASK_ALL)
100 {
101 switch (opcode)
102 {
103 case VALSCM_NOT:
104 /* Alas gdb and guile use the opposite meaning for "logical not". */
105 {
106 struct type *type = language_bool_type (language, gdbarch);
107 res_val
108 = value_from_longest (type, (LONGEST) value_logical_not (arg1));
109 }
110 break;
111 case VALSCM_NEG:
112 res_val = value_neg (arg1);
113 break;
114 case VALSCM_NOP:
115 /* Seemingly a no-op, but if X was a Scheme value it is now
116 a <gdb:value> object. */
117 res_val = arg1;
118 break;
119 case VALSCM_ABS:
120 if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
121 res_val = value_neg (arg1);
122 else
123 res_val = arg1;
124 break;
125 case VALSCM_LOGNOT:
126 res_val = value_complement (arg1);
127 break;
128 default:
129 gdb_assert_not_reached ("unsupported operation");
130 }
131 }
132 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
133
134 gdb_assert (res_val != NULL);
135 result = vlscm_scm_from_value (res_val);
136
137 do_cleanups (cleanups);
138
139 if (gdbscm_is_exception (result))
140 gdbscm_throw (result);
141
142 return result;
143}
144
145/* Returns a value object which is the result of applying the operation
146 specified by OPCODE to the given arguments.
147 If there's an error a Scheme exception is thrown. */
148
149static SCM
150vlscm_binop (enum valscm_binary_opcode opcode, SCM x, SCM y,
151 const char *func_name)
152{
153 struct gdbarch *gdbarch = get_current_arch ();
154 const struct language_defn *language = current_language;
155 struct value *arg1, *arg2;
156 SCM result = SCM_BOOL_F;
157 struct value *res_val = NULL;
158 SCM except_scm;
159 struct cleanup *cleanups;
160 volatile struct gdb_exception except;
161
162 cleanups = make_cleanup_value_free_to_mark (value_mark ());
163
164 arg1 = vlscm_convert_value_from_scheme (func_name, SCM_ARG1, x,
165 &except_scm, gdbarch, language);
166 if (arg1 == NULL)
167 {
168 do_cleanups (cleanups);
169 gdbscm_throw (except_scm);
170 }
171 arg2 = vlscm_convert_value_from_scheme (func_name, SCM_ARG2, y,
172 &except_scm, gdbarch, language);
173 if (arg2 == NULL)
174 {
175 do_cleanups (cleanups);
176 gdbscm_throw (except_scm);
177 }
178
179 TRY_CATCH (except, RETURN_MASK_ALL)
180 {
181 switch (opcode)
182 {
183 case VALSCM_ADD:
184 {
185 struct type *ltype = value_type (arg1);
186 struct type *rtype = value_type (arg2);
187
188 CHECK_TYPEDEF (ltype);
189 ltype = STRIP_REFERENCE (ltype);
190 CHECK_TYPEDEF (rtype);
191 rtype = STRIP_REFERENCE (rtype);
192
193 if (TYPE_CODE (ltype) == TYPE_CODE_PTR
194 && is_integral_type (rtype))
195 res_val = value_ptradd (arg1, value_as_long (arg2));
196 else if (TYPE_CODE (rtype) == TYPE_CODE_PTR
197 && is_integral_type (ltype))
198 res_val = value_ptradd (arg2, value_as_long (arg1));
199 else
200 res_val = value_binop (arg1, arg2, BINOP_ADD);
201 }
202 break;
203 case VALSCM_SUB:
204 {
205 struct type *ltype = value_type (arg1);
206 struct type *rtype = value_type (arg2);
207
208 CHECK_TYPEDEF (ltype);
209 ltype = STRIP_REFERENCE (ltype);
210 CHECK_TYPEDEF (rtype);
211 rtype = STRIP_REFERENCE (rtype);
212
213 if (TYPE_CODE (ltype) == TYPE_CODE_PTR
214 && TYPE_CODE (rtype) == TYPE_CODE_PTR)
215 {
216 /* A ptrdiff_t for the target would be preferable here. */
217 res_val
218 = value_from_longest (builtin_type (gdbarch)->builtin_long,
219 value_ptrdiff (arg1, arg2));
220 }
221 else if (TYPE_CODE (ltype) == TYPE_CODE_PTR
222 && is_integral_type (rtype))
223 res_val = value_ptradd (arg1, - value_as_long (arg2));
224 else
225 res_val = value_binop (arg1, arg2, BINOP_SUB);
226 }
227 break;
228 case VALSCM_MUL:
229 res_val = value_binop (arg1, arg2, BINOP_MUL);
230 break;
231 case VALSCM_DIV:
232 res_val = value_binop (arg1, arg2, BINOP_DIV);
233 break;
234 case VALSCM_REM:
235 res_val = value_binop (arg1, arg2, BINOP_REM);
236 break;
237 case VALSCM_MOD:
238 res_val = value_binop (arg1, arg2, BINOP_MOD);
239 break;
240 case VALSCM_POW:
241 res_val = value_binop (arg1, arg2, BINOP_EXP);
242 break;
243 case VALSCM_LSH:
244 res_val = value_binop (arg1, arg2, BINOP_LSH);
245 break;
246 case VALSCM_RSH:
247 res_val = value_binop (arg1, arg2, BINOP_RSH);
248 break;
249 case VALSCM_MIN:
250 res_val = value_binop (arg1, arg2, BINOP_MIN);
251 break;
252 case VALSCM_MAX:
253 res_val = value_binop (arg1, arg2, BINOP_MAX);
254 break;
255 case VALSCM_BITAND:
256 res_val = value_binop (arg1, arg2, BINOP_BITWISE_AND);
257 break;
258 case VALSCM_BITOR:
259 res_val = value_binop (arg1, arg2, BINOP_BITWISE_IOR);
260 break;
261 case VALSCM_BITXOR:
262 res_val = value_binop (arg1, arg2, BINOP_BITWISE_XOR);
263 break;
264 default:
265 gdb_assert_not_reached ("unsupported operation");
266 }
267 }
268 GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
269
270 gdb_assert (res_val != NULL);
271 result = vlscm_scm_from_value (res_val);
272
273 do_cleanups (cleanups);
274
275 if (gdbscm_is_exception (result))
276 gdbscm_throw (result);
277
278 return result;
279}
280
281/* (value-add x y) -> <gdb:value> */
282
283static SCM
284gdbscm_value_add (SCM x, SCM y)
285{
286 return vlscm_binop (VALSCM_ADD, x, y, FUNC_NAME);
287}
288
289/* (value-sub x y) -> <gdb:value> */
290
291static SCM
292gdbscm_value_sub (SCM x, SCM y)
293{
294 return vlscm_binop (VALSCM_SUB, x, y, FUNC_NAME);
295}
296
297/* (value-mul x y) -> <gdb:value> */
298
299static SCM
300gdbscm_value_mul (SCM x, SCM y)
301{
302 return vlscm_binop (VALSCM_MUL, x, y, FUNC_NAME);
303}
304
305/* (value-div x y) -> <gdb:value> */
306
307static SCM
308gdbscm_value_div (SCM x, SCM y)
309{
310 return vlscm_binop (VALSCM_DIV, x, y, FUNC_NAME);
311}
312
313/* (value-rem x y) -> <gdb:value> */
314
315static SCM
316gdbscm_value_rem (SCM x, SCM y)
317{
318 return vlscm_binop (VALSCM_REM, x, y, FUNC_NAME);
319}
320
321/* (value-mod x y) -> <gdb:value> */
322
323static SCM
324gdbscm_value_mod (SCM x, SCM y)
325{
326 return vlscm_binop (VALSCM_MOD, x, y, FUNC_NAME);
327}
328
329/* (value-pow x y) -> <gdb:value> */
330
331static SCM
332gdbscm_value_pow (SCM x, SCM y)
333{
334 return vlscm_binop (VALSCM_POW, x, y, FUNC_NAME);
335}
336
337/* (value-neg x) -> <gdb:value> */
338
339static SCM
340gdbscm_value_neg (SCM x)
341{
342 return vlscm_unop (VALSCM_NEG, x, FUNC_NAME);
343}
344
345/* (value-pos x) -> <gdb:value> */
346
347static SCM
348gdbscm_value_pos (SCM x)
349{
350 return vlscm_unop (VALSCM_NOP, x, FUNC_NAME);
351}
352
353/* (value-abs x) -> <gdb:value> */
354
355static SCM
356gdbscm_value_abs (SCM x)
357{
358 return vlscm_unop (VALSCM_ABS, x, FUNC_NAME);
359}
360
361/* (value-lsh x y) -> <gdb:value> */
362
363static SCM
364gdbscm_value_lsh (SCM x, SCM y)
365{
366 return vlscm_binop (VALSCM_LSH, x, y, FUNC_NAME);
367}
368
369/* (value-rsh x y) -> <gdb:value> */
370
371static SCM
372gdbscm_value_rsh (SCM x, SCM y)
373{
374 return vlscm_binop (VALSCM_RSH, x, y, FUNC_NAME);
375}
376
377/* (value-min x y) -> <gdb:value> */
378
379static SCM
380gdbscm_value_min (SCM x, SCM y)
381{
382 return vlscm_binop (VALSCM_MIN, x, y, FUNC_NAME);
383}
384
385/* (value-max x y) -> <gdb:value> */
386
387static SCM
388gdbscm_value_max (SCM x, SCM y)
389{
390 return vlscm_binop (VALSCM_MAX, x, y, FUNC_NAME);
391}
392
393/* (value-not x) -> <gdb:value> */
394
395static SCM
396gdbscm_value_not (SCM x)
397{
398 return vlscm_unop (VALSCM_NOT, x, FUNC_NAME);
399}
400
401/* (value-lognot x) -> <gdb:value> */
402
403static SCM
404gdbscm_value_lognot (SCM x)
405{
406 return vlscm_unop (VALSCM_LOGNOT, x, FUNC_NAME);
407}
408
409/* (value-logand x y) -> <gdb:value> */
410
411static SCM
412gdbscm_value_logand (SCM x, SCM y)
413{
414 return vlscm_binop (VALSCM_BITAND, x, y, FUNC_NAME);
415}
416
417/* (value-logior x y) -> <gdb:value> */
418
419static SCM
420gdbscm_value_logior (SCM x, SCM y)
421{
422 return vlscm_binop (VALSCM_BITOR, x, y, FUNC_NAME);
423}
424
425/* (value-logxor x y) -> <gdb:value> */
426
427static SCM
428gdbscm_value_logxor (SCM x, SCM y)
429{
430 return vlscm_binop (VALSCM_BITXOR, x, y, FUNC_NAME);
431}
432
433/* Utility to perform all value comparisons.
434 If there's an error a Scheme exception is thrown. */
435
436static SCM
437vlscm_rich_compare (int op, SCM x, SCM y, const char *func_name)
438{
439 struct gdbarch *gdbarch = get_current_arch ();
440 const struct language_defn *language = current_language;
441 struct value *v1, *v2;
442 int result = 0;
443 SCM except_scm;
444 struct cleanup *cleanups;
445 volatile struct gdb_exception except;
446
447 cleanups = make_cleanup_value_free_to_mark (value_mark ());
448
449 v1 = vlscm_convert_value_from_scheme (func_name, SCM_ARG1, x,
450 &except_scm, gdbarch, language);
451 if (v1 == NULL)
452 {
453 do_cleanups (cleanups);
454 gdbscm_throw (except_scm);
455 }
456 v2 = vlscm_convert_value_from_scheme (func_name, SCM_ARG2, y,
457 &except_scm, gdbarch, language);
458 if (v2 == NULL)
459 {
460 do_cleanups (cleanups);
461 gdbscm_throw (except_scm);
462 }
463
464 TRY_CATCH (except, RETURN_MASK_ALL)
465 {
466 switch (op)
467 {
468 case BINOP_LESS:
469 result = value_less (v1, v2);
470 break;
471 case BINOP_LEQ:
472 result = (value_less (v1, v2)
473 || value_equal (v1, v2));
474 break;
475 case BINOP_EQUAL:
476 result = value_equal (v1, v2);
477 break;
478 case BINOP_NOTEQUAL:
479 gdb_assert_not_reached ("not-equal not implemented");
480 case BINOP_GTR:
481 result = value_less (v2, v1);
482 break;
483 case BINOP_GEQ:
484 result = (value_less (v2, v1)
485 || value_equal (v1, v2));
486 break;
487 default:
488 gdb_assert_not_reached ("invalid <gdb:value> comparison");
489 }
490 }
491 do_cleanups (cleanups);
492 GDBSCM_HANDLE_GDB_EXCEPTION (except);
493
494 return scm_from_bool (result);
495}
496
497/* (value=? x y) -> boolean
498 There is no "not-equal?" function (value!= ?) on purpose.
499 We're following string=?, etc. as our Guide here. */
500
501static SCM
502gdbscm_value_eq_p (SCM x, SCM y)
503{
504 return vlscm_rich_compare (BINOP_EQUAL, x, y, FUNC_NAME);
505}
506
507/* (value<? x y) -> boolean */
508
509static SCM
510gdbscm_value_lt_p (SCM x, SCM y)
511{
512 return vlscm_rich_compare (BINOP_LESS, x, y, FUNC_NAME);
513}
514
515/* (value<=? x y) -> boolean */
516
517static SCM
518gdbscm_value_le_p (SCM x, SCM y)
519{
520 return vlscm_rich_compare (BINOP_LEQ, x, y, FUNC_NAME);
521}
522
523/* (value>? x y) -> boolean */
524
525static SCM
526gdbscm_value_gt_p (SCM x, SCM y)
527{
528 return vlscm_rich_compare (BINOP_GTR, x, y, FUNC_NAME);
529}
530
531/* (value>=? x y) -> boolean */
532
533static SCM
534gdbscm_value_ge_p (SCM x, SCM y)
535{
536 return vlscm_rich_compare (BINOP_GEQ, x, y, FUNC_NAME);
537}
538\f
539/* Subroutine of vlscm_convert_typed_value_from_scheme to simplify it.
540 Convert OBJ, a Scheme number, to a <gdb:value> object.
541 OBJ_ARG_POS is its position in the argument list, used in exception text.
542
543 TYPE is the result type. TYPE_ARG_POS is its position in
544 the argument list, used in exception text.
545 TYPE_SCM is Scheme object wrapping TYPE, used in exception text.
546
547 If the number isn't representable, e.g. it's too big, a <gdb:exception>
548 object is stored in *EXCEPT_SCMP and NULL is returned.
549 The conversion may throw a gdb error, e.g., if TYPE is invalid. */
550
551static struct value *
552vlscm_convert_typed_number (const char *func_name, int obj_arg_pos, SCM obj,
553 int type_arg_pos, SCM type_scm, struct type *type,
554 struct gdbarch *gdbarch, SCM *except_scmp)
555{
556 if (is_integral_type (type)
557 || TYPE_CODE (type) == TYPE_CODE_PTR)
558 {
559 if (TYPE_UNSIGNED (type))
560 {
561 ULONGEST max;
562
563 get_unsigned_type_max (type, &max);
564 if (!scm_is_unsigned_integer (obj, 0, max))
565 {
566 *except_scmp
567 = gdbscm_make_out_of_range_error (func_name,
568 obj_arg_pos, obj,
569 _("value out of range for type"));
570 return NULL;
571 }
572 return value_from_longest (type, gdbscm_scm_to_ulongest (obj));
573 }
574 else
575 {
576 LONGEST min, max;
577
578 get_signed_type_minmax (type, &min, &max);
579 if (!scm_is_signed_integer (obj, min, max))
580 {
581 *except_scmp
582 = gdbscm_make_out_of_range_error (func_name,
583 obj_arg_pos, obj,
584 _("value out of range for type"));
585 return NULL;
586 }
587 return value_from_longest (type, gdbscm_scm_to_longest (obj));
588 }
589 }
590 else if (TYPE_CODE (type) == TYPE_CODE_FLT)
591 return value_from_double (type, scm_to_double (obj));
592 else
593 {
594 *except_scmp = gdbscm_make_type_error (func_name, obj_arg_pos, obj,
595 NULL);
596 return NULL;
597 }
598}
599
600/* Return non-zero if OBJ, an integer, fits in TYPE. */
601
602static int
603vlscm_integer_fits_p (SCM obj, struct type *type)
604{
605 if (TYPE_UNSIGNED (type))
606 {
607 ULONGEST max;
608
609 /* If scm_is_unsigned_integer can't work with this type, just punt. */
610 if (TYPE_LENGTH (type) > sizeof (scm_t_uintmax))
611 return 0;
612 get_unsigned_type_max (type, &max);
613 return scm_is_unsigned_integer (obj, 0, max);
614 }
615 else
616 {
617 LONGEST min, max;
618
619 /* If scm_is_signed_integer can't work with this type, just punt. */
620 if (TYPE_LENGTH (type) > sizeof (scm_t_intmax))
621 return 0;
622 get_signed_type_minmax (type, &min, &max);
623 return scm_is_signed_integer (obj, min, max);
624 }
625}
626
627/* Subroutine of vlscm_convert_typed_value_from_scheme to simplify it.
628 Convert OBJ, a Scheme number, to a <gdb:value> object.
629 OBJ_ARG_POS is its position in the argument list, used in exception text.
630
631 If OBJ is an integer, then the smallest int that will hold the value in
632 the following progression is chosen:
633 int, unsigned int, long, unsigned long, long long, unsigned long long.
634 Otherwise, if OBJ is a real number, then it is converted to a double.
635 Otherwise an exception is thrown.
636
637 If the number isn't representable, e.g. it's too big, a <gdb:exception>
638 object is stored in *EXCEPT_SCMP and NULL is returned. */
639
640static struct value *
641vlscm_convert_number (const char *func_name, int obj_arg_pos, SCM obj,
642 struct gdbarch *gdbarch, SCM *except_scmp)
643{
644 const struct builtin_type *bt = builtin_type (gdbarch);
645
646 /* One thing to keep in mind here is that we are interested in the
647 target's representation of OBJ, not the host's. */
648
649 if (scm_is_exact (obj) && scm_is_integer (obj))
650 {
651 if (vlscm_integer_fits_p (obj, bt->builtin_int))
652 return value_from_longest (bt->builtin_int,
653 gdbscm_scm_to_longest (obj));
654 if (vlscm_integer_fits_p (obj, bt->builtin_unsigned_int))
655 return value_from_longest (bt->builtin_unsigned_int,
656 gdbscm_scm_to_ulongest (obj));
657 if (vlscm_integer_fits_p (obj, bt->builtin_long))
658 return value_from_longest (bt->builtin_long,
659 gdbscm_scm_to_longest (obj));
660 if (vlscm_integer_fits_p (obj, bt->builtin_unsigned_long))
661 return value_from_longest (bt->builtin_unsigned_long,
662 gdbscm_scm_to_ulongest (obj));
663 if (vlscm_integer_fits_p (obj, bt->builtin_long_long))
664 return value_from_longest (bt->builtin_long_long,
665 gdbscm_scm_to_longest (obj));
666 if (vlscm_integer_fits_p (obj, bt->builtin_unsigned_long_long))
667 return value_from_longest (bt->builtin_unsigned_long_long,
668 gdbscm_scm_to_ulongest (obj));
669 }
670 else if (scm_is_real (obj))
671 return value_from_double (bt->builtin_double, scm_to_double (obj));
672
673 *except_scmp = gdbscm_make_out_of_range_error (func_name, obj_arg_pos, obj,
674 _("value not a number representable on the target"));
675 return NULL;
676}
677
678/* Subroutine of vlscm_convert_typed_value_from_scheme to simplify it.
679 Convert BV, a Scheme bytevector, to a <gdb:value> object.
680
681 TYPE, if non-NULL, is the result type. Otherwise, a vector of type
682 uint8_t is used.
683 TYPE_SCM is Scheme object wrapping TYPE, used in exception text,
684 or #f if TYPE is NULL.
685
686 If the bytevector isn't the same size as the type, then a <gdb:exception>
687 object is stored in *EXCEPT_SCMP, and NULL is returned. */
688
689static struct value *
690vlscm_convert_bytevector (SCM bv, struct type *type, SCM type_scm,
691 int arg_pos, const char *func_name,
692 SCM *except_scmp, struct gdbarch *gdbarch)
693{
694 LONGEST length = SCM_BYTEVECTOR_LENGTH (bv);
695 struct value *value;
696
697 if (type == NULL)
698 {
699 type = builtin_type (gdbarch)->builtin_uint8;
700 type = lookup_array_range_type (type, 0, length);
701 make_vector_type (type);
702 }
703 type = check_typedef (type);
704 if (TYPE_LENGTH (type) != length)
705 {
706 *except_scmp = gdbscm_make_out_of_range_error (func_name, arg_pos,
707 type_scm,
708 _("size of type does not match size of bytevector"));
709 return NULL;
710 }
711
712 value = value_from_contents (type,
713 (gdb_byte *) SCM_BYTEVECTOR_CONTENTS (bv));
714 return value;
715}
716
717/* Convert OBJ, a Scheme value, to a <gdb:value> object.
718 OBJ_ARG_POS is its position in the argument list, used in exception text.
719
720 TYPE, if non-NULL, is the result type which must be compatible with
721 the value being converted.
722 If TYPE is NULL then a suitable default type is chosen.
723 TYPE_SCM is Scheme object wrapping TYPE, used in exception text,
724 or SCM_UNDEFINED if TYPE is NULL.
725 TYPE_ARG_POS is its position in the argument list, used in exception text,
726 or -1 if TYPE is NULL.
727
728 OBJ may also be a <gdb:value> object, in which case a copy is returned
729 and TYPE must be NULL.
730
731 If the value cannot be converted, NULL is returned and a gdb:exception
732 object is stored in *EXCEPT_SCMP.
733 Otherwise the new value is returned, added to the all_values chain. */
734
735struct value *
736vlscm_convert_typed_value_from_scheme (const char *func_name,
737 int obj_arg_pos, SCM obj,
738 int type_arg_pos, SCM type_scm,
739 struct type *type,
740 SCM *except_scmp,
741 struct gdbarch *gdbarch,
742 const struct language_defn *language)
743{
744 struct value *value = NULL;
745 SCM except_scm = SCM_BOOL_F;
746 volatile struct gdb_exception except;
747
748 if (type == NULL)
749 {
750 gdb_assert (type_arg_pos == -1);
751 gdb_assert (SCM_UNBNDP (type_scm));
752 }
753
754 *except_scmp = SCM_BOOL_F;
755
756 TRY_CATCH (except, RETURN_MASK_ALL)
757 {
758 if (vlscm_is_value (obj))
759 {
760 if (type != NULL)
761 {
762 except_scm = gdbscm_make_misc_error (func_name, type_arg_pos,
763 type_scm,
764 _("No type allowed"));
765 value = NULL;
766 }
767 else
768 value = value_copy (vlscm_scm_to_value (obj));
769 }
770 else if (gdbscm_is_true (scm_bytevector_p (obj)))
771 {
772 value = vlscm_convert_bytevector (obj, type, type_scm,
773 obj_arg_pos, func_name,
774 &except_scm, gdbarch);
775 }
776 else if (gdbscm_is_bool (obj))
777 {
778 if (type != NULL
779 && !is_integral_type (type))
780 {
781 except_scm = gdbscm_make_type_error (func_name, type_arg_pos,
782 type_scm, NULL);
783 }
784 else
785 {
786 value = value_from_longest (type
787 ? type
788 : language_bool_type (language,
789 gdbarch),
790 gdbscm_is_true (obj));
791 }
792 }
793 else if (scm_is_number (obj))
794 {
795 if (type != NULL)
796 {
797 value = vlscm_convert_typed_number (func_name, obj_arg_pos, obj,
798 type_arg_pos, type_scm, type,
799 gdbarch, &except_scm);
800 }
801 else
802 {
803 value = vlscm_convert_number (func_name, obj_arg_pos, obj,
804 gdbarch, &except_scm);
805 }
806 }
807 else if (scm_is_string (obj))
808 {
809 char *s;
810 size_t len;
811 struct cleanup *cleanup;
812
813 if (type != NULL)
814 {
815 except_scm = gdbscm_make_misc_error (func_name, type_arg_pos,
816 type_scm,
817 _("No type allowed"));
818 value = NULL;
819 }
820 else
821 {
822 /* TODO: Provide option to specify conversion strategy. */
823 s = gdbscm_scm_to_string (obj, &len,
824 target_charset (gdbarch),
825 0 /*non-strict*/,
826 &except_scm);
827 if (s != NULL)
828 {
829 cleanup = make_cleanup (xfree, s);
830 value
831 = value_cstring (s, len,
832 language_string_char_type (language,
833 gdbarch));
834 do_cleanups (cleanup);
835 }
836 else
837 value = NULL;
838 }
839 }
840 else if (lsscm_is_lazy_string (obj))
841 {
842 if (type != NULL)
843 {
844 except_scm = gdbscm_make_misc_error (func_name, type_arg_pos,
845 type_scm,
846 _("No type allowed"));
847 value = NULL;
848 }
849 else
850 {
851 value = lsscm_safe_lazy_string_to_value (obj, obj_arg_pos,
852 func_name,
853 &except_scm);
854 }
855 }
856 else /* OBJ isn't anything we support. */
857 {
858 except_scm = gdbscm_make_type_error (func_name, obj_arg_pos, obj,
859 NULL);
860 value = NULL;
861 }
862 }
863 if (except.reason < 0)
864 except_scm = gdbscm_scm_from_gdb_exception (except);
865
866 if (gdbscm_is_true (except_scm))
867 {
868 gdb_assert (value == NULL);
869 *except_scmp = except_scm;
870 }
871
872 return value;
873}
874
875/* Wrapper around vlscm_convert_typed_value_from_scheme for cases where there
876 is no supplied type. See vlscm_convert_typed_value_from_scheme for
877 details. */
878
879struct value *
880vlscm_convert_value_from_scheme (const char *func_name,
881 int obj_arg_pos, SCM obj,
882 SCM *except_scmp, struct gdbarch *gdbarch,
883 const struct language_defn *language)
884{
885 return vlscm_convert_typed_value_from_scheme (func_name, obj_arg_pos, obj,
886 -1, SCM_UNDEFINED, NULL,
887 except_scmp,
888 gdbarch, language);
889}
890\f
891/* Initialize value math support. */
892
893static const scheme_function math_functions[] =
894{
895 { "value-add", 2, 0, 0, gdbscm_value_add,
896 "\
897Return a + b." },
898
899 { "value-sub", 2, 0, 0, gdbscm_value_sub,
900 "\
901Return a - b." },
902
903 { "value-mul", 2, 0, 0, gdbscm_value_mul,
904 "\
905Return a * b." },
906
907 { "value-div", 2, 0, 0, gdbscm_value_div,
908 "\
909Return a / b." },
910
911 { "value-rem", 2, 0, 0, gdbscm_value_rem,
912 "\
913Return a % b." },
914
915 { "value-mod", 2, 0, 0, gdbscm_value_mod,
916 "\
917Return a mod b. See Knuth 1.2.4." },
918
919 { "value-pow", 2, 0, 0, gdbscm_value_pow,
920 "\
921Return pow (x, y)." },
922
923 { "value-not", 1, 0, 0, gdbscm_value_not,
924 "\
925Return !a." },
926
927 { "value-neg", 1, 0, 0, gdbscm_value_neg,
928 "\
929Return -a." },
930
931 { "value-pos", 1, 0, 0, gdbscm_value_pos,
932 "\
933Return a." },
934
935 { "value-abs", 1, 0, 0, gdbscm_value_abs,
936 "\
937Return abs (a)." },
938
939 { "value-lsh", 2, 0, 0, gdbscm_value_lsh,
940 "\
941Return a << b." },
942
943 { "value-rsh", 2, 0, 0, gdbscm_value_rsh,
944 "\
945Return a >> b." },
946
947 { "value-min", 2, 0, 0, gdbscm_value_min,
948 "\
949Return min (a, b)." },
950
951 { "value-max", 2, 0, 0, gdbscm_value_max,
952 "\
953Return max (a, b)." },
954
955 { "value-lognot", 1, 0, 0, gdbscm_value_lognot,
956 "\
957Return ~a." },
958
959 { "value-logand", 2, 0, 0, gdbscm_value_logand,
960 "\
961Return a & b." },
962
963 { "value-logior", 2, 0, 0, gdbscm_value_logior,
964 "\
965Return a | b." },
966
967 { "value-logxor", 2, 0, 0, gdbscm_value_logxor,
968 "\
969Return a ^ b." },
970
971 { "value=?", 2, 0, 0, gdbscm_value_eq_p,
972 "\
973Return a == b." },
974
975 { "value<?", 2, 0, 0, gdbscm_value_lt_p,
976 "\
977Return a < b." },
978
979 { "value<=?", 2, 0, 0, gdbscm_value_le_p,
980 "\
981Return a <= b." },
982
983 { "value>?", 2, 0, 0, gdbscm_value_gt_p,
984 "\
985Return a > b." },
986
987 { "value>=?", 2, 0, 0, gdbscm_value_ge_p,
988 "\
989Return a >= b." },
990
991 END_FUNCTIONS
992};
993
994void
995gdbscm_initialize_math (void)
996{
997 gdbscm_define_functions (math_functions, 1);
998}
GDB Binutils - Deliverables
This page took 0.095687 seconds and 4 git commands to generate.