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