GDB (xrefs)
Loading...
Searching...
No Matches
scm-math.c
Go to the documentation of this file.
1/* GDB/Scheme support for math operations on values.
2
3 Copyright (C) 2008-2023 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 "target-float.h"
28#include "symtab.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
38{
43 /* Note: This is Scheme's "logical not", not GDB's.
44 GDB calls this UNOP_COMPLEMENT. */
46};
47
65
66/* If TYPE is a reference, return the target; otherwise return TYPE. */
67#define STRIP_REFERENCE(TYPE) \
68 ((TYPE->code () == TYPE_CODE_REF) ? ((TYPE)->target_type ()) : (TYPE))
69
70/* Helper for vlscm_unop. Contains all the code that may throw a GDB
71 exception. */
72
73static SCM
75 const char *func_name)
76{
77 struct gdbarch *gdbarch = get_current_arch ();
79
80 scoped_value_mark free_values;
81
82 SCM except_scm;
83 value *arg1 = vlscm_convert_value_from_scheme (func_name, SCM_ARG1, x,
84 &except_scm, gdbarch,
85 language);
86 if (arg1 == NULL)
87 return except_scm;
88
89 struct value *res_val = NULL;
90
91 switch (opcode)
92 {
93 case VALSCM_NOT:
94 /* Alas gdb and guile use the opposite meaning for "logical
95 not". */
96 {
98 res_val
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 (arg1->type (), 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");
122 }
123
124 gdb_assert (res_val != NULL);
125 return vlscm_scm_from_value (res_val);
126}
127
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);
132}
133
134/* Helper for vlscm_binop. Contains all the code that may throw a GDB
135 exception. */
136
137static SCM
139 const char *func_name)
140{
141 struct gdbarch *gdbarch = get_current_arch ();
143 struct value *arg1, *arg2;
144 struct value *res_val = NULL;
145 SCM except_scm;
146
147 scoped_value_mark free_values;
148
149 arg1 = vlscm_convert_value_from_scheme (func_name, SCM_ARG1, x,
150 &except_scm, gdbarch, language);
151 if (arg1 == NULL)
152 return except_scm;
153
154 arg2 = vlscm_convert_value_from_scheme (func_name, SCM_ARG2, y,
155 &except_scm, gdbarch, language);
156 if (arg2 == NULL)
157 return except_scm;
158
159 switch (opcode)
160 {
161 case VALSCM_ADD:
162 {
163 struct type *ltype = arg1->type ();
164 struct type *rtype = arg2->type ();
165
166 ltype = check_typedef (ltype);
167 ltype = STRIP_REFERENCE (ltype);
168 rtype = check_typedef (rtype);
169 rtype = STRIP_REFERENCE (rtype);
170
171 if (ltype->code () == TYPE_CODE_PTR
172 && is_integral_type (rtype))
173 res_val = value_ptradd (arg1, value_as_long (arg2));
174 else if (rtype->code () == TYPE_CODE_PTR
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 = arg1->type ();
184 struct type *rtype = arg2->type ();
185
186 ltype = check_typedef (ltype);
187 ltype = STRIP_REFERENCE (ltype);
188 rtype = check_typedef (rtype);
189 rtype = STRIP_REFERENCE (rtype);
190
191 if (ltype->code () == TYPE_CODE_PTR
192 && rtype->code () == TYPE_CODE_PTR)
193 {
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));
198 }
199 else if (ltype->code () == TYPE_CODE_PTR
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");
244 }
245
246 gdb_assert (res_val != NULL);
247 return vlscm_scm_from_value (res_val);
248}
249
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. */
253
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);
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
321{
322 return vlscm_unop (VALSCM_NEG, x, FUNC_NAME);
323}
324
325/* (value-pos x) -> <gdb:value> */
326
327static SCM
329{
330 return vlscm_unop (VALSCM_NOP, x, FUNC_NAME);
331}
332
333/* (value-abs x) -> <gdb:value> */
334
335static SCM
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
377{
378 return vlscm_unop (VALSCM_NOT, x, FUNC_NAME);
379}
380
381/* (value-lognot x) -> <gdb:value> */
382
383static SCM
385{
387}
388
389/* (value-logand x y) -> <gdb:value> */
390
391static SCM
393{
394 return vlscm_binop (VALSCM_BITAND, x, y, FUNC_NAME);
395}
396
397/* (value-logior x y) -> <gdb:value> */
398
399static SCM
401{
402 return vlscm_binop (VALSCM_BITOR, x, y, FUNC_NAME);
403}
404
405/* (value-logxor x y) -> <gdb:value> */
406
407static SCM
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{
419 return gdbscm_wrap ([=]
420 {
421 struct gdbarch *gdbarch = get_current_arch ();
423 SCM except_scm;
424
425 scoped_value_mark free_values;
426
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;
432
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;
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");
463 }
464 return scm_from_bool (result);
465 });
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
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{
528 {
529 if (type->is_unsigned ())
530 {
531 ULONGEST max = get_unsigned_type_max (type);
532 if (!scm_is_unsigned_integer (obj, 0, max))
533 {
534 *except_scmp
536 (func_name, obj_arg_pos, obj,
537 _("value out of range for type"));
538 return NULL;
539 }
541 }
542 else
543 {
544 LONGEST min, max;
545
546 get_signed_type_minmax (type, &min, &max);
547 if (!scm_is_signed_integer (obj, min, max))
548 {
549 *except_scmp
551 (func_name, obj_arg_pos, obj,
552 _("value out of range for type"));
553 return NULL;
554 }
556 }
557 }
558 else if (type->code () == TYPE_CODE_PTR)
559 {
560 CORE_ADDR max = get_pointer_type_max (type);
561 if (!scm_is_unsigned_integer (obj, 0, max))
562 {
563 *except_scmp
565 (func_name, obj_arg_pos, obj,
566 _("value out of range for type"));
567 return NULL;
568 }
570 }
571 else if (type->code () == TYPE_CODE_FLT)
572 return value_from_host_double (type, scm_to_double (obj));
573 else
574 {
575 *except_scmp = gdbscm_make_type_error (func_name, obj_arg_pos, obj,
576 NULL);
577 return NULL;
578 }
579}
580
581/* Return non-zero if OBJ, an integer, fits in TYPE. */
582
583static int
585{
586 if (type->is_unsigned ())
587 {
588 /* If scm_is_unsigned_integer can't work with this type, just punt. */
589 if (type->length () > sizeof (uintmax_t))
590 return 0;
591
592 ULONGEST max = get_unsigned_type_max (type);
593 return scm_is_unsigned_integer (obj, 0, max);
594 }
595 else
596 {
597 LONGEST min, max;
598
599 /* If scm_is_signed_integer can't work with this type, just punt. */
600 if (type->length () > sizeof (intmax_t))
601 return 0;
602 get_signed_type_minmax (type, &min, &max);
603 return scm_is_signed_integer (obj, min, max);
604 }
605}
606
607/* Subroutine of vlscm_convert_typed_value_from_scheme to simplify it.
608 Convert OBJ, a Scheme number, to a <gdb:value> object.
609 OBJ_ARG_POS is its position in the argument list, used in exception text.
610
611 If OBJ is an integer, then the smallest int that will hold the value in
612 the following progression is chosen:
613 int, unsigned int, long, unsigned long, long long, unsigned long long.
614 Otherwise, if OBJ is a real number, then it is converted to a double.
615 Otherwise an exception is thrown.
616
617 If the number isn't representable, e.g. it's too big, a <gdb:exception>
618 object is stored in *EXCEPT_SCMP and NULL is returned. */
619
620static struct value *
621vlscm_convert_number (const char *func_name, int obj_arg_pos, SCM obj,
622 struct gdbarch *gdbarch, SCM *except_scmp)
623{
624 const struct builtin_type *bt = builtin_type (gdbarch);
625
626 /* One thing to keep in mind here is that we are interested in the
627 target's representation of OBJ, not the host's. */
628
629 if (scm_is_exact (obj) && scm_is_integer (obj))
630 {
631 if (vlscm_integer_fits_p (obj, bt->builtin_int))
632 return value_from_longest (bt->builtin_int,
634 if (vlscm_integer_fits_p (obj, bt->builtin_unsigned_int))
635 return value_from_longest (bt->builtin_unsigned_int,
637 if (vlscm_integer_fits_p (obj, bt->builtin_long))
638 return value_from_longest (bt->builtin_long,
640 if (vlscm_integer_fits_p (obj, bt->builtin_unsigned_long))
641 return value_from_longest (bt->builtin_unsigned_long,
643 if (vlscm_integer_fits_p (obj, bt->builtin_long_long))
644 return value_from_longest (bt->builtin_long_long,
646 if (vlscm_integer_fits_p (obj, bt->builtin_unsigned_long_long))
647 return value_from_longest (bt->builtin_unsigned_long_long,
649 }
650 else if (scm_is_real (obj))
651 return value_from_host_double (bt->builtin_double, scm_to_double (obj));
652
653 *except_scmp = gdbscm_make_out_of_range_error (func_name, obj_arg_pos, obj,
654 _("value not a number representable on the target"));
655 return NULL;
656}
657
658/* Subroutine of vlscm_convert_typed_value_from_scheme to simplify it.
659 Convert BV, a Scheme bytevector, to a <gdb:value> object.
660
661 TYPE, if non-NULL, is the result type. Otherwise, a vector of type
662 uint8_t is used.
663 TYPE_SCM is Scheme object wrapping TYPE, used in exception text,
664 or #f if TYPE is NULL.
665
666 If the bytevector isn't the same size as the type, then a <gdb:exception>
667 object is stored in *EXCEPT_SCMP, and NULL is returned. */
668
669static struct value *
670vlscm_convert_bytevector (SCM bv, struct type *type, SCM type_scm,
671 int arg_pos, const char *func_name,
672 SCM *except_scmp, struct gdbarch *gdbarch)
673{
674 LONGEST length = SCM_BYTEVECTOR_LENGTH (bv);
675 struct value *value;
676
677 if (type == NULL)
678 {
680 type = lookup_array_range_type (type, 0, length);
682 }
684 if (type->length () != length)
685 {
686 *except_scmp = gdbscm_make_out_of_range_error (func_name, arg_pos,
687 type_scm,
688 _("size of type does not match size of bytevector"));
689 return NULL;
690 }
691
693 (gdb_byte *) SCM_BYTEVECTOR_CONTENTS (bv));
694 return value;
695}
696
697/* Convert OBJ, a Scheme value, to a <gdb:value> object.
698 OBJ_ARG_POS is its position in the argument list, used in exception text.
699
700 TYPE, if non-NULL, is the result type which must be compatible with
701 the value being converted.
702 If TYPE is NULL then a suitable default type is chosen.
703 TYPE_SCM is Scheme object wrapping TYPE, used in exception text,
704 or SCM_UNDEFINED if TYPE is NULL.
705 TYPE_ARG_POS is its position in the argument list, used in exception text,
706 or -1 if TYPE is NULL.
707
708 OBJ may also be a <gdb:value> object, in which case a copy is returned
709 and TYPE must be NULL.
710
711 If the value cannot be converted, NULL is returned and a gdb:exception
712 object is stored in *EXCEPT_SCMP.
713 Otherwise the new value is returned, added to the all_values chain. */
714
715struct value *
717 int obj_arg_pos, SCM obj,
718 int type_arg_pos, SCM type_scm,
719 struct type *type,
720 SCM *except_scmp,
721 struct gdbarch *gdbarch,
722 const struct language_defn *language)
723{
724 struct value *value = NULL;
725 SCM except_scm = SCM_BOOL_F;
726
727 if (type == NULL)
728 {
729 gdb_assert (type_arg_pos == -1);
730 gdb_assert (SCM_UNBNDP (type_scm));
731 }
732
733 *except_scmp = SCM_BOOL_F;
734
735 try
736 {
737 if (vlscm_is_value (obj))
738 {
739 if (type != NULL)
740 {
741 except_scm = gdbscm_make_misc_error (func_name, type_arg_pos,
742 type_scm,
743 _("No type allowed"));
744 value = NULL;
745 }
746 else
747 value = vlscm_scm_to_value (obj)->copy ();
748 }
749 else if (gdbscm_is_true (scm_bytevector_p (obj)))
750 {
751 value = vlscm_convert_bytevector (obj, type, type_scm,
752 obj_arg_pos, func_name,
753 &except_scm, gdbarch);
754 }
755 else if (gdbscm_is_bool (obj))
756 {
757 if (type != NULL
759 {
760 except_scm = gdbscm_make_type_error (func_name, type_arg_pos,
761 type_scm, NULL);
762 }
763 else
764 {
766 ? type
768 gdbarch),
769 gdbscm_is_true (obj));
770 }
771 }
772 else if (scm_is_number (obj))
773 {
774 if (type != NULL)
775 {
776 value = vlscm_convert_typed_number (func_name, obj_arg_pos, obj,
777 type_arg_pos, type_scm, type,
778 gdbarch, &except_scm);
779 }
780 else
781 {
782 value = vlscm_convert_number (func_name, obj_arg_pos, obj,
783 gdbarch, &except_scm);
784 }
785 }
786 else if (scm_is_string (obj))
787 {
788 size_t len;
789
790 if (type != NULL)
791 {
792 except_scm = gdbscm_make_misc_error (func_name, type_arg_pos,
793 type_scm,
794 _("No type allowed"));
795 value = NULL;
796 }
797 else
798 {
799 /* TODO: Provide option to specify conversion strategy. */
800 gdb::unique_xmalloc_ptr<char> s
801 = gdbscm_scm_to_string (obj, &len,
803 0 /*non-strict*/,
804 &except_scm);
805 if (s != NULL)
806 value = language->value_string (gdbarch, s.get (), len);
807 else
808 value = NULL;
809 }
810 }
811 else if (lsscm_is_lazy_string (obj))
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 value = lsscm_safe_lazy_string_to_value (obj, obj_arg_pos,
823 func_name,
824 &except_scm);
825 }
826 }
827 else /* OBJ isn't anything we support. */
828 {
829 except_scm = gdbscm_make_type_error (func_name, obj_arg_pos, obj,
830 NULL);
831 value = NULL;
832 }
833 }
834 catch (const gdb_exception &except)
835 {
836 except_scm = gdbscm_scm_from_gdb_exception (unpack (except));
837 }
838
839 if (gdbscm_is_true (except_scm))
840 {
841 gdb_assert (value == NULL);
842 *except_scmp = except_scm;
843 }
844
845 return value;
846}
847
848/* Wrapper around vlscm_convert_typed_value_from_scheme for cases where there
849 is no supplied type. See vlscm_convert_typed_value_from_scheme for
850 details. */
851
852struct value *
853vlscm_convert_value_from_scheme (const char *func_name,
854 int obj_arg_pos, SCM obj,
855 SCM *except_scmp, struct gdbarch *gdbarch,
856 const struct language_defn *language)
857{
858 return vlscm_convert_typed_value_from_scheme (func_name, obj_arg_pos, obj,
859 -1, SCM_UNDEFINED, NULL,
860 except_scmp,
862}
863
864/* Initialize value math support. */
865
867{
868 { "value-add", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_add),
869 "\
870Return a + b." },
871
872 { "value-sub", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_sub),
873 "\
874Return a - b." },
875
876 { "value-mul", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_mul),
877 "\
878Return a * b." },
879
880 { "value-div", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_div),
881 "\
882Return a / b." },
883
884 { "value-rem", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_rem),
885 "\
886Return a % b." },
887
888 { "value-mod", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_mod),
889 "\
890Return a mod b. See Knuth 1.2.4." },
891
892 { "value-pow", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_pow),
893 "\
894Return pow (x, y)." },
895
896 { "value-not", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_not),
897 "\
898Return !a." },
899
900 { "value-neg", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_neg),
901 "\
902Return -a." },
903
904 { "value-pos", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_pos),
905 "\
906Return a." },
907
908 { "value-abs", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_abs),
909 "\
910Return abs (a)." },
911
912 { "value-lsh", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_lsh),
913 "\
914Return a << b." },
915
916 { "value-rsh", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_rsh),
917 "\
918Return a >> b." },
919
920 { "value-min", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_min),
921 "\
922Return min (a, b)." },
923
924 { "value-max", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_max),
925 "\
926Return max (a, b)." },
927
928 { "value-lognot", 1, 0, 0, as_a_scm_t_subr (gdbscm_value_lognot),
929 "\
930Return ~a." },
931
932 { "value-logand", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_logand),
933 "\
934Return a & b." },
935
936 { "value-logior", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_logior),
937 "\
938Return a | b." },
939
940 { "value-logxor", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_logxor),
941 "\
942Return a ^ b." },
943
944 { "value=?", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_eq_p),
945 "\
946Return a == b." },
947
948 { "value<?", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_lt_p),
949 "\
950Return a < b." },
951
952 { "value<=?", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_le_p),
953 "\
954Return a <= b." },
955
956 { "value>?", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_gt_p),
957 "\
958Return a > b." },
959
960 { "value>=?", 2, 0, 0, as_a_scm_t_subr (gdbscm_value_ge_p),
961 "\
962Return a >= b." },
963
965};
966
967void
struct gdbarch * get_current_arch(void)
Definition arch-utils.c:846
const char * target_charset(struct gdbarch *gdbarch)
Definition charset.c:424
language
Definition defs.h:211
@ not_lval
Definition defs.h:361
int is_integral_type(struct type *t)
Definition gdbtypes.c:3654
struct type * lookup_array_range_type(struct type *element_type, LONGEST low_bound, LONGEST high_bound)
Definition gdbtypes.c:1397
CORE_ADDR get_pointer_type_max(struct type *type)
Definition gdbtypes.c:1895
void get_signed_type_minmax(struct type *type, LONGEST *min, LONGEST *max)
Definition gdbtypes.c:1879
const struct builtin_type * builtin_type(struct gdbarch *gdbarch)
Definition gdbtypes.c:6168
ULONGEST get_unsigned_type_max(struct type *type)
Definition gdbtypes.c:1862
struct type * check_typedef(struct type *type)
Definition gdbtypes.c:2966
void make_vector_type(struct type *array_type)
Definition gdbtypes.c:1468
SCM gdbscm_make_out_of_range_error(const char *subr, int arg_pos, SCM bad_value, const char *error)
#define gdbscm_is_true(scm)
SCM gdbscm_make_type_error(const char *subr, int arg_pos, SCM bad_value, const char *expected_type)
SCM gdbscm_wrap(Function &&func, Args &&... args)
#define END_FUNCTIONS
struct value * vlscm_scm_to_value(SCM scm)
Definition scm-value.c:311
int vlscm_is_value(SCM scm)
Definition scm-value.c:234
gdbscm_gdb_exception unpack(const gdb_exception &exc)
SCM gdbscm_make_misc_error(const char *subr, int arg_pos, SCM bad_value, const char *error)
SCM vlscm_scm_from_value(struct value *value)
Definition scm-value.c:252
SCM gdbscm_scm_from_gdb_exception(const gdbscm_gdb_exception &exception)
int lsscm_is_lazy_string(SCM scm)
ULONGEST gdbscm_scm_to_ulongest(SCM u)
Definition scm-utils.c:576
LONGEST gdbscm_scm_to_longest(SCM l)
Definition scm-utils.c:557
#define gdbscm_is_bool(scm)
SCM gdb::unique_xmalloc_ptr< char > gdbscm_scm_to_string(SCM string, size_t *lenp, const char *charset, int strict, SCM *except_scmp)
Definition scm-string.c:117
void gdbscm_define_functions(const scheme_function *, int is_public)
Definition scm-utils.c:44
struct value * lsscm_safe_lazy_string_to_value(SCM string, int arg_pos, const char *func_name, SCM *except_scmp)
static scm_t_subr as_a_scm_t_subr(SCM(*func)(void))
#define FUNC_NAME
const struct language_defn * current_language
Definition language.c:82
struct type * language_bool_type(const struct language_defn *la, struct gdbarch *gdbarch)
Definition language.c:888
int value
Definition py-param.c:79
valscm_binary_opcode
Definition scm-math.c:49
@ VALSCM_RSH
Definition scm-math.c:58
@ VALSCM_MUL
Definition scm-math.c:52
@ VALSCM_ADD
Definition scm-math.c:50
@ VALSCM_SUB
Definition scm-math.c:51
@ VALSCM_BITXOR
Definition scm-math.c:63
@ VALSCM_MOD
Definition scm-math.c:55
@ VALSCM_MIN
Definition scm-math.c:59
@ VALSCM_LSH
Definition scm-math.c:57
@ VALSCM_MAX
Definition scm-math.c:60
@ VALSCM_BITOR
Definition scm-math.c:62
@ VALSCM_DIV
Definition scm-math.c:53
@ VALSCM_BITAND
Definition scm-math.c:61
@ VALSCM_REM
Definition scm-math.c:54
@ VALSCM_POW
Definition scm-math.c:56
static SCM gdbscm_value_logior(SCM x, SCM y)
Definition scm-math.c:400
static SCM gdbscm_value_pos(SCM x)
Definition scm-math.c:328
struct value * vlscm_convert_value_from_scheme(const char *func_name, int obj_arg_pos, SCM obj, SCM *except_scmp, struct gdbarch *gdbarch, const struct language_defn *language)
Definition scm-math.c:853
struct value * vlscm_convert_typed_value_from_scheme(const char *func_name, int obj_arg_pos, SCM obj, int type_arg_pos, SCM type_scm, struct type *type, SCM *except_scmp, struct gdbarch *gdbarch, const struct language_defn *language)
Definition scm-math.c:716
static SCM gdbscm_value_add(SCM x, SCM y)
Definition scm-math.c:264
static SCM gdbscm_value_max(SCM x, SCM y)
Definition scm-math.c:368
static SCM gdbscm_value_eq_p(SCM x, SCM y)
Definition scm-math.c:473
static SCM gdbscm_value_lognot(SCM x)
Definition scm-math.c:384
static SCM gdbscm_value_lsh(SCM x, SCM y)
Definition scm-math.c:344
static SCM gdbscm_value_abs(SCM x)
Definition scm-math.c:336
static SCM gdbscm_value_rsh(SCM x, SCM y)
Definition scm-math.c:352
static SCM gdbscm_value_rem(SCM x, SCM y)
Definition scm-math.c:296
static SCM vlscm_unop_gdbthrow(enum valscm_unary_opcode opcode, SCM x, const char *func_name)
Definition scm-math.c:74
static int vlscm_integer_fits_p(SCM obj, struct type *type)
Definition scm-math.c:584
static SCM gdbscm_value_logxor(SCM x, SCM y)
Definition scm-math.c:408
static SCM gdbscm_value_mul(SCM x, SCM y)
Definition scm-math.c:280
static SCM gdbscm_value_neg(SCM x)
Definition scm-math.c:320
static SCM gdbscm_value_gt_p(SCM x, SCM y)
Definition scm-math.c:497
static const scheme_function math_functions[]
Definition scm-math.c:866
static SCM vlscm_binop_gdbthrow(enum valscm_binary_opcode opcode, SCM x, SCM y, const char *func_name)
Definition scm-math.c:138
void gdbscm_initialize_math(void)
Definition scm-math.c:968
static struct value * vlscm_convert_bytevector(SCM bv, struct type *type, SCM type_scm, int arg_pos, const char *func_name, SCM *except_scmp, struct gdbarch *gdbarch)
Definition scm-math.c:670
static SCM gdbscm_value_div(SCM x, SCM y)
Definition scm-math.c:288
static SCM gdbscm_value_le_p(SCM x, SCM y)
Definition scm-math.c:489
static SCM gdbscm_value_pow(SCM x, SCM y)
Definition scm-math.c:312
static SCM vlscm_binop(enum valscm_binary_opcode opcode, SCM x, SCM y, const char *func_name)
Definition scm-math.c:255
valscm_unary_opcode
Definition scm-math.c:38
@ VALSCM_LOGNOT
Definition scm-math.c:45
@ VALSCM_NOT
Definition scm-math.c:39
@ VALSCM_ABS
Definition scm-math.c:42
@ VALSCM_NOP
Definition scm-math.c:41
@ VALSCM_NEG
Definition scm-math.c:40
static SCM gdbscm_value_min(SCM x, SCM y)
Definition scm-math.c:360
#define STRIP_REFERENCE(TYPE)
Definition scm-math.c:67
static SCM gdbscm_value_logand(SCM x, SCM y)
Definition scm-math.c:392
static SCM vlscm_unop(enum valscm_unary_opcode opcode, SCM x, const char *func_name)
Definition scm-math.c:129
static SCM gdbscm_value_mod(SCM x, SCM y)
Definition scm-math.c:304
static SCM gdbscm_value_sub(SCM x, SCM y)
Definition scm-math.c:272
static struct value * vlscm_convert_number(const char *func_name, int obj_arg_pos, SCM obj, struct gdbarch *gdbarch, SCM *except_scmp)
Definition scm-math.c:621
static SCM gdbscm_value_lt_p(SCM x, SCM y)
Definition scm-math.c:481
static SCM gdbscm_value_ge_p(SCM x, SCM y)
Definition scm-math.c:505
static SCM vlscm_rich_compare(int op, SCM x, SCM y, const char *func_name)
Definition scm-math.c:417
static struct value * vlscm_convert_typed_number(const char *func_name, int obj_arg_pos, SCM obj, int type_arg_pos, SCM type_scm, struct type *type, struct gdbarch *gdbarch, SCM *except_scmp)
Definition scm-math.c:523
static SCM gdbscm_value_not(SCM x)
Definition scm-math.c:376
struct type * builtin_uint8
Definition gdbtypes.h:2114
type_code code() const
Definition gdbtypes.h:956
ULONGEST length() const
Definition gdbtypes.h:983
bool is_unsigned() const
Definition gdbtypes.h:1100
Definition value.h:130
static struct value * zero(struct type *type, enum lval_type lv)
Definition value.c:3426
struct value * copy() const
Definition value.c:1494
struct type * type() const
Definition value.h:180
bool value_logical_not(struct value *arg1)
Definition valarith.c:1501
struct value * value_neg(struct value *arg1)
Definition valarith.c:1722
struct value * value_complement(struct value *arg1)
Definition valarith.c:1770
int value_equal(struct value *arg1, struct value *arg2)
Definition valarith.c:1559
int value_less(struct value *arg1, struct value *arg2)
Definition valarith.c:1648
struct value * value_ptradd(struct value *arg1, LONGEST arg2)
Definition valarith.c:79
LONGEST value_ptrdiff(struct value *arg1, struct value *arg2)
Definition valarith.c:100
struct value * value_binop(struct value *arg1, struct value *arg2, enum exp_opcode op)
Definition valarith.c:1464
struct value * value_from_longest(struct type *type, LONGEST num)
Definition value.c:3438
struct value * value_from_contents(struct type *type, const gdb_byte *contents)
Definition value.c:3581
LONGEST value_as_long(struct value *val)
Definition value.c:2554
struct value * value_from_host_double(struct type *type, double d)
Definition value.c:3514
struct value * value_from_pointer(struct type *type, CORE_ADDR addr)
Definition value.c:3500