diff options
author | Andrew Burgess <andrew.burgess@embecosm.com> | 2019-02-13 17:10:18 +0000 |
---|---|---|
committer | Andrew Burgess <andrew.burgess@embecosm.com> | 2019-04-30 10:10:24 +0100 |
commit | b6d03bb2b65ac5c919f1d08674bbaa2a9bfb2d0c (patch) | |
tree | ba4019eaf0e387569cb2f165b226b45140fff8c3 /gdb/f-lang.c | |
parent | 83228e93efa82f84a132f7cec44d0e760d4ad22b (diff) | |
download | binutils-gdb-b6d03bb2b65ac5c919f1d08674bbaa2a9bfb2d0c.tar.gz |
gdb/fortran: Additional builtin procedures
Add some additional builtin procedures for Fortran, these are MOD,
CEILING, FLOOR, MODULO, and CMPLX.
gdb/ChangeLog:
* f-exp.y (BINOP_INTRINSIC): New token.
(exp): New parser rule handling BINOP_INTRINSIC.
(f77_keywords): Add new builtin procedures.
* f-lang.c (evaluate_subexp_f): Handle BINOP_MOD, UNOP_FORTRAN_CEILING,
UNOP_FORTRAN_FLOOR, BINOP_FORTRAN_MODULO, BINOP_FORTRAN_CMPLX.
(operator_length_f): Handle UNOP_FORTRAN_CEILING,
UNOP_FORTRAN_FLOOR, BINOP_FORTRAN_MODULO, BINOP_FORTRAN_CMPLX.
(print_unop_subexp_f): New function.
(print_binop_subexp_f): New function.
(print_subexp_f): Handle UNOP_FORTRAN_CEILING, UNOP_FORTRAN_FLOOR,
BINOP_FORTRAN_MODULO, BINOP_FORTRAN_CMPLX.
(dump_subexp_body_f): Likewise.
(operator_check_f): Likewise.
* fortran-operator.def: Add UNOP_FORTRAN_CEILING, UNOP_FORTRAN_FLOOR,
BINOP_FORTRAN_MODULO, BINOP_FORTRAN_CMPLX
gdb/testsuite/ChangeLog:
* gdb.fortran/intrinsics.exp: Extend to cover MOD, CEILING, FLOOR,
MODULO, CMPLX.
Diffstat (limited to 'gdb/f-lang.c')
-rw-r--r-- | gdb/f-lang.c | 180 |
1 files changed, 175 insertions, 5 deletions
diff --git a/gdb/f-lang.c b/gdb/f-lang.c index ecb69e76e61..cc4e154f47a 100644 --- a/gdb/f-lang.c +++ b/gdb/f-lang.c @@ -246,7 +246,7 @@ struct value * evaluate_subexp_f (struct type *expect_type, struct expression *exp, int *pos, enum noside noside) { - struct value *arg1 = NULL; + struct value *arg1 = NULL, *arg2 = NULL; enum exp_opcode op; int pc; struct type *type; @@ -284,6 +284,115 @@ evaluate_subexp_f (struct type *expect_type, struct expression *exp, } error (_("ABS of type %s not supported"), TYPE_SAFE_NAME (type)); + case BINOP_MOD: + arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); + arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside); + if (noside == EVAL_SKIP) + return eval_skip_value (exp); + type = value_type (arg1); + if (TYPE_CODE (type) != TYPE_CODE (value_type (arg2))) + error (_("non-matching types for parameters to MOD ()")); + switch (TYPE_CODE (type)) + { + case TYPE_CODE_FLT: + { + double d1 + = target_float_to_host_double (value_contents (arg1), + value_type (arg1)); + double d2 + = target_float_to_host_double (value_contents (arg2), + value_type (arg2)); + double d3 = fmod (d1, d2); + return value_from_host_double (type, d3); + } + case TYPE_CODE_INT: + { + LONGEST v1 = value_as_long (arg1); + LONGEST v2 = value_as_long (arg2); + if (v2 == 0) + error (_("calling MOD (N, 0) is undefined")); + LONGEST v3 = v1 - (v1 / v2) * v2; + return value_from_longest (value_type (arg1), v3); + } + } + error (_("MOD of type %s not supported"), TYPE_SAFE_NAME (type)); + + case UNOP_FORTRAN_CEILING: + { + arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); + if (noside == EVAL_SKIP) + return eval_skip_value (exp); + type = value_type (arg1); + if (TYPE_CODE (type) != TYPE_CODE_FLT) + error (_("argument to CEILING must be of type float")); + double val + = target_float_to_host_double (value_contents (arg1), + value_type (arg1)); + val = ceil (val); + return value_from_host_double (type, val); + } + + case UNOP_FORTRAN_FLOOR: + { + arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); + if (noside == EVAL_SKIP) + return eval_skip_value (exp); + type = value_type (arg1); + if (TYPE_CODE (type) != TYPE_CODE_FLT) + error (_("argument to FLOOR must be of type float")); + double val + = target_float_to_host_double (value_contents (arg1), + value_type (arg1)); + val = floor (val); + return value_from_host_double (type, val); + } + + case BINOP_FORTRAN_MODULO: + { + arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); + arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside); + if (noside == EVAL_SKIP) + return eval_skip_value (exp); + type = value_type (arg1); + if (TYPE_CODE (type) != TYPE_CODE (value_type (arg2))) + error (_("non-matching types for parameters to MODULO ()")); + /* MODULO(A, P) = A - FLOOR (A / P) * P */ + switch (TYPE_CODE (type)) + { + case TYPE_CODE_INT: + { + LONGEST a = value_as_long (arg1); + LONGEST p = value_as_long (arg2); + LONGEST result = a - (a / p) * p; + if (result != 0 && (a < 0) != (p < 0)) + result += p; + return value_from_longest (value_type (arg1), result); + } + case TYPE_CODE_FLT: + { + double a + = target_float_to_host_double (value_contents (arg1), + value_type (arg1)); + double p + = target_float_to_host_double (value_contents (arg2), + value_type (arg2)); + double result = fmod (a, p); + if (result != 0 && (a < 0.0) != (p < 0.0)) + result += p; + return value_from_host_double (type, result); + } + } + error (_("MODULO of type %s not supported"), TYPE_SAFE_NAME (type)); + } + + case BINOP_FORTRAN_CMPLX: + arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside); + arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside); + if (noside == EVAL_SKIP) + return eval_skip_value (exp); + type = builtin_f_type(exp->gdbarch)->builtin_complex_s16; + return value_literal_complex (arg1, arg2, type); + case UNOP_FORTRAN_KIND: arg1 = evaluate_subexp (NULL, exp, pos, EVAL_AVOID_SIDE_EFFECTS); type = value_type (arg1); @@ -335,15 +444,55 @@ operator_length_f (const struct expression *exp, int pc, int *oplenp, return; case UNOP_FORTRAN_KIND: + case UNOP_FORTRAN_FLOOR: + case UNOP_FORTRAN_CEILING: oplen = 1; args = 1; break; + + case BINOP_FORTRAN_CMPLX: + case BINOP_FORTRAN_MODULO: + oplen = 1; + args = 2; + break; } *oplenp = oplen; *argsp = args; } +/* Helper for PRINT_SUBEXP_F. Arguments are as for PRINT_SUBEXP_F, except + the extra argument NAME which is the text that should be printed as the + name of this operation. */ + +static void +print_unop_subexp_f (struct expression *exp, int *pos, + struct ui_file *stream, enum precedence prec, + const char *name) +{ + (*pos)++; + fprintf_filtered (stream, "%s(", name); + print_subexp (exp, pos, stream, PREC_SUFFIX); + fputs_filtered (")", stream); +} + +/* Helper for PRINT_SUBEXP_F. Arguments are as for PRINT_SUBEXP_F, except + the extra argument NAME which is the text that should be printed as the + name of this operation. */ + +static void +print_binop_subexp_f (struct expression *exp, int *pos, + struct ui_file *stream, enum precedence prec, + const char *name) +{ + (*pos)++; + fprintf_filtered (stream, "%s(", name); + print_subexp (exp, pos, stream, PREC_SUFFIX); + fputs_filtered (",", stream); + print_subexp (exp, pos, stream, PREC_SUFFIX); + fputs_filtered (")", stream); +} + /* Special expression printing for Fortran. */ static void @@ -360,10 +509,23 @@ print_subexp_f (struct expression *exp, int *pos, return; case UNOP_FORTRAN_KIND: - (*pos)++; - fputs_filtered ("KIND(", stream); - print_subexp (exp, pos, stream, PREC_SUFFIX); - fputs_filtered (")", stream); + print_unop_subexp_f (exp, pos, stream, prec, "KIND"); + return; + + case UNOP_FORTRAN_FLOOR: + print_unop_subexp_f (exp, pos, stream, prec, "FLOOR"); + return; + + case UNOP_FORTRAN_CEILING: + print_unop_subexp_f (exp, pos, stream, prec, "CEILING"); + return; + + case BINOP_FORTRAN_CMPLX: + print_binop_subexp_f (exp, pos, stream, prec, "CMPLX"); + return; + + case BINOP_FORTRAN_MODULO: + print_binop_subexp_f (exp, pos, stream, prec, "MODULO"); return; } } @@ -401,6 +563,10 @@ dump_subexp_body_f (struct expression *exp, return dump_subexp_body_standard (exp, stream, elt); case UNOP_FORTRAN_KIND: + case UNOP_FORTRAN_FLOOR: + case UNOP_FORTRAN_CEILING: + case BINOP_FORTRAN_CMPLX: + case BINOP_FORTRAN_MODULO: operator_length_f (exp, (elt + 1), &oplen, &nargs); break; } @@ -425,6 +591,10 @@ operator_check_f (struct expression *exp, int pos, switch (elts[pos].opcode) { case UNOP_FORTRAN_KIND: + case UNOP_FORTRAN_FLOOR: + case UNOP_FORTRAN_CEILING: + case BINOP_FORTRAN_CMPLX: + case BINOP_FORTRAN_MODULO: /* Any references to objfiles are held in the arguments to this expression, not within the expression itself, so no additional checking is required here, the outer expression iteration code |