@@ -1,3 +1,15 @@
+2019-03-18 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_CEILING,
+ UNOP_FLOOR, BINOP_MODULE, BINOP_CMPLX.
+ * std-operator.def: Add UNOP_CEILING, UNOP_FLOOR, BINOP_MODULE,
+ BINOP_CMPLX
+
2019-03-18 Andrew Burgess <andrew.burgess@embecosm.com>
* eval.c (evaluate_subexp_standard): Handle internal functions
@@ -168,7 +168,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
@@ -257,6 +257,10 @@ exp : UNOP_INTRINSIC '(' exp ')'
{ write_exp_elt_opcode (pstate, $1); }
;
+exp : BINOP_INTRINSIC '(' exp ',' exp ')'
+ { write_exp_elt_opcode (pstate, $1); }
+ ;
+
arglist :
;
@@ -953,7 +957,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_FLOOR, false },
+ { "ceiling", UNOP_INTRINSIC, UNOP_CEILING, false },
+ { "modulo", BINOP_INTRINSIC, BINOP_MODULO, false },
+ { "cmplx", BINOP_INTRINSIC, BINOP_CMPLX, false },
};
/* Implementation of a dynamically expandable buffer for processing input
@@ -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_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_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_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_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_KIND:
arg1 = evaluate_subexp (NULL, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
type = value_type (arg1);
@@ -54,6 +54,9 @@ OP (BINOP_EXP) /* Exponentiation */
OP (BINOP_MIN) /* <? */
OP (BINOP_MAX) /* >? */
+OP (BINOP_CMPLX) /* Fortran builtin. */
+OP (BINOP_MODULO) /* Fortran builtin. */
+
/* STRUCTOP_MEMBER is used for pointer-to-member constructs.
X . * Y translates into X STRUCTOP_MEMBER Y. */
OP (STRUCTOP_MEMBER)
@@ -250,6 +253,9 @@ OP (UNOP_MIN)
OP (UNOP_ODD)
OP (UNOP_TRUNC)
+OP (UNOP_FLOOR) /* Fortran builtin. */
+OP (UNOP_CEILING) /* Fortran builtin. */
+
OP (OP_BOOL) /* Modula-2 builtin BOOLEAN type */
OP (OP_M2_STRING) /* Modula-2 string constants */
@@ -1,3 +1,8 @@
+2019-03-18 Andrew Burgess <andrew.burgess@embecosm.com>
+
+ * gdb.fortran/intrinsics.exp: Extend to cover MOD, CEILING, FLOOR,
+ MODULO, CMPLX.
+
2019-03-18 Andrew Burgess <andrew.burgess@embecosm.com>
* gdb.python/py-function.exp: Check calling helper function from
@@ -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\\)"