[3/8] gdb/fortran: Additional builtin procedures

Message ID 12614ec36a52fca2dda675732df04310c2865b29.1552913183.git.andrew.burgess@embecosm.com
State New
Headers show
Series
  • Series of Fortran type printing patches
Related show

Commit Message

Andrew Burgess March 18, 2019, 12:52 p.m.
Add some additional builtin procedures for Fortran.

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_CEILING,
	UNOP_FLOOR, BINOP_MODULE, BINOP_CMPLX.
	* std-operator.def: Add UNOP_CEILING, UNOP_FLOOR, BINOP_MODULE,
	BINOP_CMPLX

gdb/testsuite/ChangeLog:

	* gdb.fortran/intrinsics.exp: Extend to cover MOD, CEILING, FLOOR,
	MODULO, CMPLX.
---
 gdb/ChangeLog                            |  12 ++++
 gdb/f-exp.y                              |  13 +++-
 gdb/f-lang.c                             | 111 ++++++++++++++++++++++++++++++-
 gdb/std-operator.def                     |   6 ++
 gdb/testsuite/ChangeLog                  |   5 ++
 gdb/testsuite/gdb.fortran/intrinsics.exp |  35 ++++++++++
 6 files changed, 179 insertions(+), 3 deletions(-)

-- 
2.14.5

Comments

Tom Tromey March 19, 2019, 8:06 p.m. | #1
>>>>> "Andrew" == Andrew Burgess <andrew.burgess@embecosm.com> writes:


Andrew> 	* f-lang.c (evaluate_subexp_f): Handle BINOP_MOD, UNOP_CEILING,
Andrew> 	UNOP_FLOOR, BINOP_MODULE, BINOP_CMPLX.

I think MODULE should be MODULO here.

Andrew> +  { "mod", BINOP_INTRINSIC, BINOP_MOD, false },
...
Andrew> +  { "modulo", BINOP_INTRINSIC, BINOP_MODULO, false },

... however, it seems confusing to have both BINOP_MOD and BINOP_MODULO.
Maybe the new one could mention Fortran somehow?

Tom

Patch

diff --git a/gdb/ChangeLog b/gdb/ChangeLog
index 51863b21dc6..6fcb1c630be 100644
--- a/gdb/ChangeLog
+++ b/gdb/ChangeLog
@@ -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
diff --git a/gdb/f-exp.y b/gdb/f-exp.y
index 7e838b0a93a..6a26dd2249b 100644
--- a/gdb/f-exp.y
+++ b/gdb/f-exp.y
@@ -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
diff --git a/gdb/f-lang.c b/gdb/f-lang.c
index 7bd119690b4..dd31b42ccd0 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_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);
diff --git a/gdb/std-operator.def b/gdb/std-operator.def
index e26861bd131..15d3140c47e 100644
--- a/gdb/std-operator.def
+++ b/gdb/std-operator.def
@@ -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 */
 
diff --git a/gdb/testsuite/ChangeLog b/gdb/testsuite/ChangeLog
index 6094d773163..31541d86374 100644
--- a/gdb/testsuite/ChangeLog
+++ b/gdb/testsuite/ChangeLog
@@ -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
diff --git a/gdb/testsuite/gdb.fortran/intrinsics.exp b/gdb/testsuite/gdb.fortran/intrinsics.exp
index 00396c74c2f..64d9e56daab 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\\)"