From patchwork Mon Mar 18 12:52:18 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Andrew Burgess X-Patchwork-Id: 31883 Received: (qmail 22532 invoked by alias); 18 Mar 2019 12:52:38 -0000 Mailing-List: contact gdb-patches-help@sourceware.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Subscribe: List-Archive: List-Post: List-Help: , Sender: gdb-patches-owner@sourceware.org Delivered-To: mailing list gdb-patches@sourceware.org Received: (qmail 22458 invoked by uid 89); 18 Mar 2019 12:52:38 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-18.3 required=5.0 tests=AWL, BAYES_00, GIT_PATCH_0, GIT_PATCH_1, GIT_PATCH_2, GIT_PATCH_3, RCVD_IN_DNSWL_NONE, SPF_PASS autolearn=ham version=3.3.1 spammy=85, 91, january, FLOOR X-HELO: mail-wm1-f48.google.com Received: from mail-wm1-f48.google.com (HELO mail-wm1-f48.google.com) (209.85.128.48) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Mon, 18 Mar 2019 12:52:35 +0000 Received: by mail-wm1-f48.google.com with SMTP id o10so14284819wmc.1 for ; Mon, 18 Mar 2019 05:52:35 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=embecosm.com; s=google; h=from:to:cc:subject:date:message-id:in-reply-to:references :in-reply-to:references; bh=sJ8oR8I28qxc1gEk1LWiVmyzMAbgASDStzsGIttkGzo=; b=bZipWRsjjmRsS0/IeLEb0gup47VJo7so7apFd34hw+btT02skkOj1kAE9MPmlULe+o YQ05w8Ydb7AdI+M0UI+q7HGXejbGkSLkv91cm/CCdGq40bkCfwO00s9fjCZwGgVKdc5i p82LQp4Efr81gNZMwsYNZ6+5Np68DCoFQdNgRyUa7LMglx9Mr9dNEGlW1yXeF5xE0JL7 9dPlN4Sry5Q05TSi0o8tWwFEA0J+TCJs+4ENAViPwS4KGeSm3etf5XxEWGz+QU41vwsh 2NY1r01G4yMb/HX75jeDdbgd+WlX5BPcVJgS5DKJV5bVg3d96207maEP6eDzZlYZ/9WE 6f4Q== Return-Path: Received: from localhost (host86-142-70-198.range86-142.btcentralplus.com. [86.142.70.198]) by smtp.gmail.com with ESMTPSA id l5sm10288748wmi.24.2019.03.18.05.52.31 (version=TLS1_2 cipher=ECDHE-RSA-CHACHA20-POLY1305 bits=256/256); Mon, 18 Mar 2019 05:52:31 -0700 (PDT) From: Andrew Burgess To: gdb-patches@sourceware.org Cc: Richard Bunt , Andrew Burgess Subject: [PATCH 3/8] gdb/fortran: Additional builtin procedures Date: Mon, 18 Mar 2019 12:52:18 +0000 Message-Id: <12614ec36a52fca2dda675732df04310c2865b29.1552913183.git.andrew.burgess@embecosm.com> In-Reply-To: References: In-Reply-To: References: X-IsSubscribed: yes 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(-) 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 + Chris January + David Lecomber + + * 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 * 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 DOLLAR_VARIABLE %token ASSIGN_MODIFY -%token UNOP_INTRINSIC +%token 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_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 + + * gdb.fortran/intrinsics.exp: Extend to cover MOD, CEILING, FLOOR, + MODULO, CMPLX. + 2019-03-18 Andrew Burgess * 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\\)"