GDB (xrefs)
scm-math.c
Go to the documentation of this file.
1 /* GDB/Scheme support for math operations on values.
2 
3  Copyright (C) 2008-2015 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 "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 
40 {
45  /* Note: This is Scheme's "logical not", not GDB's.
46  GDB calls this UNOP_COMPLEMENT. */
48 };
49 
51 {
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 
76 static SCM
77 vlscm_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;
86 
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 
97  TRY
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  }
130  CATCH (except, RETURN_MASK_ALL)
131  {
133  }
134  END_CATCH
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 
151 static SCM
152 vlscm_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;
162 
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 
180  TRY
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 
189  CHECK_TYPEDEF (ltype);
190  ltype = STRIP_REFERENCE (ltype);
191  CHECK_TYPEDEF (rtype);
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 
209  CHECK_TYPEDEF (ltype);
210  ltype = STRIP_REFERENCE (ltype);
211  CHECK_TYPEDEF (rtype);
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  }
269  CATCH (except, RETURN_MASK_ALL)
270  {
272  }
273  END_CATCH
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 
288 static SCM
289 gdbscm_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 
296 static SCM
297 gdbscm_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 
304 static SCM
305 gdbscm_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 
312 static SCM
313 gdbscm_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 
320 static SCM
321 gdbscm_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 
328 static SCM
329 gdbscm_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 
336 static SCM
337 gdbscm_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 
344 static SCM
346 {
347  return vlscm_unop (VALSCM_NEG, x, FUNC_NAME);
348 }
349 
350 /* (value-pos x) -> <gdb:value> */
351 
352 static SCM
354 {
355  return vlscm_unop (VALSCM_NOP, x, FUNC_NAME);
356 }
357 
358 /* (value-abs x) -> <gdb:value> */
359 
360 static SCM
362 {
363  return vlscm_unop (VALSCM_ABS, x, FUNC_NAME);
364 }
365 
366 /* (value-lsh x y) -> <gdb:value> */
367 
368 static SCM
369 gdbscm_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 
376 static SCM
377 gdbscm_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 
384 static SCM
385 gdbscm_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 
392 static SCM
393 gdbscm_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 
400 static SCM
402 {
403  return vlscm_unop (VALSCM_NOT, x, FUNC_NAME);
404 }
405 
406 /* (value-lognot x) -> <gdb:value> */
407 
408 static SCM
410 {
411  return vlscm_unop (VALSCM_LOGNOT, x, FUNC_NAME);
412 }
413 
414 /* (value-logand x y) -> <gdb:value> */
415 
416 static SCM
417 gdbscm_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 
424 static SCM
425 gdbscm_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 
432 static SCM
433 gdbscm_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 
441 static SCM
442 vlscm_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;
450  struct gdb_exception except = exception_none;
451 
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 
469  TRY
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  }
496  CATCH (ex, RETURN_MASK_ALL)
497  {
498  except = ex;
499  }
500  END_CATCH
501 
502  do_cleanups (cleanups);
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 
512 static SCM
513 gdbscm_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 
520 static SCM
521 gdbscm_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 
528 static SCM
529 gdbscm_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 
536 static SCM
537 gdbscm_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 
544 static SCM
545 gdbscm_value_ge_p (SCM x, SCM y)
546 {
547  return vlscm_rich_compare (BINOP_GEQ, x, y, FUNC_NAME);
548 }
549 
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 
562 static struct value *
563 vlscm_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 
613 static int
614 vlscm_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 
651 static struct value *
652 vlscm_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));
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));
673  gdbscm_scm_to_ulongest (obj));
676  gdbscm_scm_to_longest (obj));
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 
700 static struct value *
701 vlscm_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 
746 struct value *
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;
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 
766  TRY
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  }
873  CATCH (except, RETURN_MASK_ALL)
874  {
875  except_scm = gdbscm_scm_from_gdb_exception (except);
876  }
877  END_CATCH
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 
892 struct value *
893 vlscm_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 
904 /* Initialize value math support. */
905 
906 static const scheme_function math_functions[] =
907 {
908  { "value-add", 2, 0, 0, gdbscm_value_add,
909  "\
910 Return a + b." },
911 
912  { "value-sub", 2, 0, 0, gdbscm_value_sub,
913  "\
914 Return a - b." },
915 
916  { "value-mul", 2, 0, 0, gdbscm_value_mul,
917  "\
918 Return a * b." },
919 
920  { "value-div", 2, 0, 0, gdbscm_value_div,
921  "\
922 Return a / b." },
923 
924  { "value-rem", 2, 0, 0, gdbscm_value_rem,
925  "\
926 Return a % b." },
927 
928  { "value-mod", 2, 0, 0, gdbscm_value_mod,
929  "\
930 Return a mod b. See Knuth 1.2.4." },
931 
932  { "value-pow", 2, 0, 0, gdbscm_value_pow,
933  "\
934 Return pow (x, y)." },
935 
936  { "value-not", 1, 0, 0, gdbscm_value_not,
937  "\
938 Return !a." },
939 
940  { "value-neg", 1, 0, 0, gdbscm_value_neg,
941  "\
942 Return -a." },
943 
944  { "value-pos", 1, 0, 0, gdbscm_value_pos,
945  "\
946 Return a." },
947 
948  { "value-abs", 1, 0, 0, gdbscm_value_abs,
949  "\
950 Return abs (a)." },
951 
952  { "value-lsh", 2, 0, 0, gdbscm_value_lsh,
953  "\
954 Return a << b." },
955 
956  { "value-rsh", 2, 0, 0, gdbscm_value_rsh,
957  "\
958 Return a >> b." },
959 
960  { "value-min", 2, 0, 0, gdbscm_value_min,
961  "\
962 Return min (a, b)." },
963 
964  { "value-max", 2, 0, 0, gdbscm_value_max,
965  "\
966 Return max (a, b)." },
967 
968  { "value-lognot", 1, 0, 0, gdbscm_value_lognot,
969  "\
970 Return ~a." },
971 
972  { "value-logand", 2, 0, 0, gdbscm_value_logand,
973  "\
974 Return a & b." },
975 
976  { "value-logior", 2, 0, 0, gdbscm_value_logior,
977  "\
978 Return a | b." },
979 
980  { "value-logxor", 2, 0, 0, gdbscm_value_logxor,
981  "\
982 Return a ^ b." },
983 
984  { "value=?", 2, 0, 0, gdbscm_value_eq_p,
985  "\
986 Return a == b." },
987 
988  { "value<?", 2, 0, 0, gdbscm_value_lt_p,
989  "\
990 Return a < b." },
991 
992  { "value<=?", 2, 0, 0, gdbscm_value_le_p,
993  "\
994 Return a <= b." },
995 
996  { "value>?", 2, 0, 0, gdbscm_value_gt_p,
997  "\
998 Return a > b." },
999 
1000  { "value>=?", 2, 0, 0, gdbscm_value_ge_p,
1001  "\
1002 Return a >= b." },
1003 
1005 };
1006 
1007 void
1009 {
1010  gdbscm_define_functions (math_functions, 1);
1011 }
struct value * value_zero(struct type *type, enum lval_type lv)
Definition: valops.c:842
static SCM gdbscm_value_rsh(SCM x, SCM y)
Definition: scm-math.c:377
struct value * value_mark(void)
Definition: value.c:1499
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:701
static SCM gdbscm_value_pos(SCM x)
Definition: scm-math.c:353
const char * target_charset(struct gdbarch *gdbarch)
Definition: charset.c:407
struct type * lookup_array_range_type(struct type *element_type, LONGEST low_bound, LONGEST high_bound)
Definition: gdbtypes.c:1128
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:893
void gdbscm_define_functions(const scheme_function *, int is_public)
Definition: scm-utils.c:44
struct type * builtin_unsigned_int
Definition: gdbtypes.h:1488
void xfree(void *)
Definition: common-utils.c:97
valscm_binary_opcode
Definition: scm-math.c:50
static SCM gdbscm_value_not(SCM x)
Definition: scm-math.c:401
struct value * value_from_contents(struct type *type, const gdb_byte *contents)
Definition: value.c:3553
static SCM gdbscm_value_rem(SCM x, SCM y)
Definition: scm-math.c:321
LONGEST value_as_long(struct value *val)
Definition: value.c:2654
LONGEST value_ptrdiff(struct value *arg1, struct value *arg2)
Definition: valarith.c:105
struct type * language_string_char_type(const struct language_defn *la, struct gdbarch *gdbarch)
Definition: language.c:956
const struct builtin_type * builtin_type(struct gdbarch *gdbarch)
Definition: gdbtypes.c:4766
#define FUNC_NAME
struct type * builtin_uint8
Definition: gdbtypes.h:1515
static SCM gdbscm_value_min(SCM x, SCM y)
Definition: scm-math.c:385
const struct gdb_exception exception_none
int vlscm_is_value(SCM scm)
Definition: scm-value.c:240
SCM gdbscm_make_out_of_range_error(const char *subr, int arg_pos, SCM bad_value, const char *error)
struct value * value_copy(struct value *arg)
Definition: value.c:1667
void gdbscm_initialize_math(void)
Definition: scm-math.c:1008
struct value * lsscm_safe_lazy_string_to_value(SCM string, int arg_pos, const char *func_name, SCM *except_scmp)
#define gdbscm_is_bool(scm)
#define _(String)
Definition: gdb_locale.h:40
static SCM gdbscm_value_logxor(SCM x, SCM y)
Definition: scm-math.c:433
#define END_CATCH
SCM vlscm_scm_from_value(struct value *value)
Definition: scm-value.c:258
int gdbscm_is_exception(SCM scm)
SCM gdbscm_make_type_error(const char *subr, int arg_pos, SCM bad_value, const char *expected_type)
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:652
#define gdbscm_is_true(scm)
static SCM gdbscm_value_pow(SCM x, SCM y)
Definition: scm-math.c:337
static SCM gdbscm_value_abs(SCM x)
Definition: scm-math.c:361
#define TRY
static SCM gdbscm_value_lsh(SCM x, SCM y)
Definition: scm-math.c:369
valscm_unary_opcode
Definition: scm-math.c:39
struct value * value_ptradd(struct value *arg1, LONGEST arg2)
Definition: valarith.c:84
static SCM gdbscm_value_eq_p(SCM x, SCM y)
Definition: scm-math.c:513
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:747
struct type * check_typedef(struct type *type)
Definition: gdbtypes.c:2217
#define CATCH(EXCEPTION, MASK)
struct type * builtin_unsigned_long
Definition: gdbtypes.h:1489
static SCM gdbscm_value_gt_p(SCM x, SCM y)
Definition: scm-math.c:537
SCM gdbscm_scm_from_gdb_exception(struct gdb_exception exception)
struct cleanup * make_cleanup_value_free_to_mark(struct value *mark)
Definition: utils.c:388
#define gdb_assert_not_reached(message)
Definition: gdb_assert.h:56
int is_integral_type(struct type *t)
Definition: gdbtypes.c:2690
static SCM gdbscm_value_mod(SCM x, SCM y)
Definition: scm-math.c:329
struct cleanup * make_cleanup(make_cleanup_ftype *function, void *arg)
Definition: cleanups.c:117
Definition: gdbtypes.h:749
void gdbscm_throw(SCM exception) ATTRIBUTE_NORETURN
struct gdbarch * get_current_arch(void)
Definition: arch-utils.c:781
void get_signed_type_minmax(struct type *type, LONGEST *min, LONGEST *max)
Definition: gdbtypes.c:1655
#define gdb_assert(expr)
Definition: gdb_assert.h:33
struct type * language_bool_type(const struct language_defn *la, struct gdbarch *gdbarch)
Definition: language.c:966
struct value * value_from_longest(struct type *type, LONGEST num)
Definition: value.c:3464
#define min(a, b)
Definition: defs.h:106
struct type * builtin_long
Definition: gdbtypes.h:1484
int lsscm_is_lazy_string(SCM scm)
static SCM gdbscm_value_lt_p(SCM x, SCM y)
Definition: scm-math.c:521
ULONGEST gdbscm_scm_to_ulongest(SCM u)
Definition: scm-utils.c:563
struct value * value_from_double(struct type *type, DOUBLEST num)
Definition: value.c:3563
int value_equal(struct value *arg1, struct value *arg2)
Definition: valarith.c:1574
static SCM vlscm_unop(enum valscm_unary_opcode opcode, SCM x, const char *func_name)
Definition: scm-math.c:77
void get_unsigned_type_max(struct type *type, ULONGEST *max)
Definition: gdbtypes.c:1638
struct type * builtin_unsigned_long_long
Definition: gdbtypes.h:1498
#define TYPE_UNSIGNED(t)
Definition: gdbtypes.h:233
Definition: value.c:172
static SCM gdbscm_value_le_p(SCM x, SCM y)
Definition: scm-math.c:529
static SCM vlscm_binop(enum valscm_binary_opcode opcode, SCM x, SCM y, const char *func_name)
Definition: scm-math.c:152
static SCM gdbscm_value_ge_p(SCM x, SCM y)
Definition: scm-math.c:545
bfd_byte gdb_byte
Definition: common-types.h:38
static SCM gdbscm_value_mul(SCM x, SCM y)
Definition: scm-math.c:305
#define END_FUNCTIONS
const struct language_defn * current_language
Definition: language.c:85
struct type * builtin_double
Definition: gdbtypes.h:1491
struct value * value_neg(struct value *arg1)
Definition: valarith.c:1767
#define max(a, b)
Definition: defs.h:109
LONGEST gdbscm_scm_to_longest(SCM l)
Definition: scm-utils.c:544
#define TYPE_CODE(thistype)
Definition: gdbtypes.h:1240
static SCM gdbscm_value_logior(SCM x, SCM y)
Definition: scm-math.c:425
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:563
int value_less(struct value *arg1, struct value *arg2)
Definition: valarith.c:1673
struct value * value_complement(struct value *arg1)
Definition: valarith.c:1822
struct value * value_cstring(char *ptr, ssize_t len, struct type *char_type)
Definition: valops.c:1642
#define GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS(exception, cleanups)
#define CHECK_TYPEDEF(TYPE)
Definition: gdbtypes.h:1817
static SCM gdbscm_value_add(SCM x, SCM y)
Definition: scm-math.c:289
int value_logical_not(struct value *arg1)
Definition: valarith.c:1513
struct value * value_binop(struct value *arg1, struct value *arg2, enum exp_opcode op)
Definition: valarith.c:1476
static SCM gdbscm_value_neg(SCM x)
Definition: scm-math.c:345
SCM gdbscm_make_misc_error(const char *subr, int arg_pos, SCM bad_value, const char *error)
static SCM gdbscm_value_max(SCM x, SCM y)
Definition: scm-math.c:393
static SCM vlscm_rich_compare(int op, SCM x, SCM y, const char *func_name)
Definition: scm-math.c:442
unsigned long long ULONGEST
Definition: common-types.h:53
struct type * builtin_long_long
Definition: gdbtypes.h:1497
#define GDBSCM_HANDLE_GDB_EXCEPTION(exception)
language
Definition: defs.h:167
struct type * value_type(const struct value *value)
Definition: value.c:1021
struct value * vlscm_scm_to_value(SCM scm)
Definition: scm-value.c:300
#define TYPE_LENGTH(thistype)
Definition: gdbtypes.h:1237
Definition: defs.h:353
#define STRIP_REFERENCE(TYPE)
Definition: scm-math.c:69
static SCM gdbscm_value_lognot(SCM x)
Definition: scm-math.c:409
SCM char * gdbscm_scm_to_string(SCM string, size_t *lenp, const char *charset, int strict, SCM *except_scmp)
Definition: scm-string.c:120
void make_vector_type(struct type *array_type)
Definition: gdbtypes.c:1206
long long LONGEST
Definition: common-types.h:52
void do_cleanups(struct cleanup *old_chain)
Definition: cleanups.c:175
static SCM gdbscm_value_div(SCM x, SCM y)
Definition: scm-math.c:313
static SCM gdbscm_value_sub(SCM x, SCM y)
Definition: scm-math.c:297
static int vlscm_integer_fits_p(SCM obj, struct type *type)
Definition: scm-math.c:614
struct type * builtin_int
Definition: gdbtypes.h:1483
const ULONGEST const LONGEST len
Definition: target.h:309
static SCM gdbscm_value_logand(SCM x, SCM y)
Definition: scm-math.c:417