diff options
| -rw-r--r-- | gdb/ChangeLog | 20 | ||||
| -rw-r--r-- | gdb/f-exp.y | 13 | ||||
| -rw-r--r-- | gdb/f-lang.c | 180 | ||||
| -rw-r--r-- | gdb/fortran-operator.def | 5 | ||||
| -rw-r--r-- | gdb/testsuite/ChangeLog | 5 | ||||
| -rw-r--r-- | gdb/testsuite/gdb.fortran/intrinsics.exp | 35 |
6 files changed, 251 insertions, 7 deletions
diff --git a/gdb/ChangeLog b/gdb/ChangeLog index 3e3ea93..f6a1976 100644 --- a/gdb/ChangeLog +++ b/gdb/ChangeLog @@ -1,4 +1,24 @@ 2019-04-30 Andrew Burgess <andrew.burgess@embecosm.com> + Chris January <chris.january@arm.com> + David Lecomber <david.lecomber@arm.com> + + * 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 + +2019-04-30 Andrew Burgess <andrew.burgess@embecosm.com> * gdb/expprint.c (dump_subexp_body_standard): Remove use of UNOP_KIND. diff --git a/gdb/f-exp.y b/gdb/f-exp.y index dec8848..14ea386 100644 --- a/gdb/f-exp.y +++ b/gdb/f-exp.y @@ -174,7 +174,7 @@ static int parse_number (struct parser_state *, const char *, int, %token <voidval> DOLLAR_VARIABLE %token <opcode> ASSIGN_MODIFY -%token <opcode> UNOP_INTRINSIC +%token <opcode> UNOP_INTRINSIC BINOP_INTRINSIC %left ',' %left ABOVE_COMMA @@ -263,6 +263,10 @@ exp : UNOP_INTRINSIC '(' exp ')' { write_exp_elt_opcode (pstate, $1); } ; +exp : BINOP_INTRINSIC '(' exp ',' exp ')' + { write_exp_elt_opcode (pstate, $1); } + ; + arglist : ; @@ -959,7 +963,12 @@ static const struct token f77_keywords[] = /* The following correspond to actual functions in Fortran and are case insensitive. */ { "kind", KIND, BINOP_END, false }, - { "abs", UNOP_INTRINSIC, UNOP_ABS, false } + { "abs", UNOP_INTRINSIC, UNOP_ABS, false }, + { "mod", BINOP_INTRINSIC, BINOP_MOD, false }, + { "floor", UNOP_INTRINSIC, UNOP_FORTRAN_FLOOR, false }, + { "ceiling", UNOP_INTRINSIC, UNOP_FORTRAN_CEILING, false }, + { "modulo", BINOP_INTRINSIC, BINOP_FORTRAN_MODULO, false }, + { "cmplx", BINOP_INTRINSIC, BINOP_FORTRAN_CMPLX, false }, }; /* Implementation of a dynamically expandable buffer for processing input diff --git a/gdb/f-lang.c b/gdb/f-lang.c index ecb69e7..cc4e154 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 diff --git a/gdb/fortran-operator.def b/gdb/fortran-operator.def index c3176de..cb40108 100644 --- a/gdb/fortran-operator.def +++ b/gdb/fortran-operator.def @@ -19,4 +19,9 @@ /* Single operand builtins. */ OP (UNOP_FORTRAN_KIND) +OP (UNOP_FORTRAN_FLOOR) +OP (UNOP_FORTRAN_CEILING) +/* Two operand builtins. */ +OP (BINOP_FORTRAN_CMPLX) +OP (BINOP_FORTRAN_MODULO) diff --git a/gdb/testsuite/ChangeLog b/gdb/testsuite/ChangeLog index 6d9ac5a..7489ab9 100644 --- a/gdb/testsuite/ChangeLog +++ b/gdb/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2019-04-30 Andrew Burgess <andrew.burgess@embecosm.com> + + * gdb.fortran/intrinsics.exp: Extend to cover MOD, CEILING, FLOOR, + MODULO, CMPLX. + 2019-04-29 Andrew Burgess <andrew.burgess@embecosm.com> Richard Bunt <richard.bunt@arm.com> diff --git a/gdb/testsuite/gdb.fortran/intrinsics.exp b/gdb/testsuite/gdb.fortran/intrinsics.exp index 00396c7..64d9e56 100644 --- a/gdb/testsuite/gdb.fortran/intrinsics.exp +++ b/gdb/testsuite/gdb.fortran/intrinsics.exp @@ -49,3 +49,38 @@ gdb_test "p abs (11)" " = 11" # rounding, which can vary. gdb_test "p abs (-9.1)" " = 9.$decimal" gdb_test "p abs (9.1)" " = 9.$decimal" + +# Test MOD + +gdb_test "p mod (3.0, 2.0)" " = 1" +gdb_test "ptype mod (3.0, 2.0)" "type = real\\*8" +gdb_test "p mod (2.0, 3.0)" " = 2" +gdb_test "p mod (8, 5)" " = 3" +gdb_test "ptype mod (8, 5)" "type = int" +gdb_test "p mod (-8, 5)" " = -3" +gdb_test "p mod (8, -5)" " = 3" +gdb_test "p mod (-8, -5)" " = -3" + +# Test CEILING + +gdb_test "p ceiling (3.7)" " = 4" +gdb_test "p ceiling (-3.7)" " = -3" + +# Test FLOOR + +gdb_test "p floor (3.7)" " = 3" +gdb_test "p floor (-3.7)" " = -4" + +# Test MODULO + +gdb_test "p MODULO (8,5)" " = 3" +gdb_test "ptype MODULO (8,5)" "type = int" +gdb_test "p MODULO (-8,5)" " = 2" +gdb_test "p MODULO (8,-5)" " = -2" +gdb_test "p MODULO (-8,-5)" " = -3" +gdb_test "p MODULO (3.0,2.0)" " = 1" +gdb_test "ptype MODULO (3.0,2.0)" "type = real\\*8" + +# Test CMPLX + +gdb_test "p CMPLX (4.1, 2.0)" " = \\(4.$decimal,2\\)" |