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