From patchwork Tue Apr 2 23:58:37 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Andrew Burgess X-Patchwork-Id: 32127 Received: (qmail 81630 invoked by alias); 2 Apr 2019 23:58:58 -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 81523 invoked by uid 89); 2 Apr 2019 23:58:57 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-25.6 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=ABS, ceiling, 9527 X-HELO: mail-wm1-f44.google.com Received: from mail-wm1-f44.google.com (HELO mail-wm1-f44.google.com) (209.85.128.44) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Tue, 02 Apr 2019 23:58:54 +0000 Received: by mail-wm1-f44.google.com with SMTP id z6so3507953wmi.0 for ; Tue, 02 Apr 2019 16:58:53 -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=7QwtdzrogBZRhhH4oR3Z5g78ZbUjXDiiXLnbIFot9yo=; b=H6JZPwWnPNlX7HY6oEzbedAyyY85xmlgiPMpr8Ns81z69sExWTUjs54nrNbxJUmI6q g/sl6VHIZTpjqZHAPezKeBwiQTF0klGlWizw9NbO06Wj8opoPFpMjZmGYLZ11PtIMS5/ cVHisBbBdagzFGSHNDE/9NyQJ65j+BdiVBfIPz7j4MhPEzxt7ulLZcFbdAyteE2HeC9P hgiyIksiNgjJRIUc1dI/gnvgdSl0FPgPmXOX+mP44/PFCjlY1nD0ybNAgf6r1k7rX3X6 7tvF7ec/aYsv3VnB4cr9dquijeS4d+puA24IFPRSY62cj83yYlKdZEMqw+lyb42lkFxw 3gow== Return-Path: Received: from localhost (host81-151-161-58.range81-151.btcentralplus.com. [81.151.161.58]) by smtp.gmail.com with ESMTPSA id a17sm14415387wmg.40.2019.04.02.16.58.50 (version=TLS1_2 cipher=ECDHE-RSA-CHACHA20-POLY1305 bits=256/256); Tue, 02 Apr 2019 16:58:51 -0700 (PDT) From: Andrew Burgess To: gdb-patches@sourceware.org Cc: Richard Bunt , Andrew Burgess Subject: [PATCHv2 3/8] gdb/fortran: Additional builtin procedures Date: Wed, 3 Apr 2019 00:58:37 +0100 Message-Id: In-Reply-To: References: In-Reply-To: References: X-IsSubscribed: yes 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. --- gdb/ChangeLog | 20 ++++ gdb/f-exp.y | 13 ++- gdb/f-lang.c | 178 ++++++++++++++++++++++++++++++- gdb/fortran-operator.def | 5 + gdb/testsuite/ChangeLog | 5 + gdb/testsuite/gdb.fortran/intrinsics.exp | 35 ++++++ 6 files changed, 249 insertions(+), 7 deletions(-) diff --git a/gdb/f-exp.y b/gdb/f-exp.y index 06851a0aa7c..32427aede75 100644 --- a/gdb/f-exp.y +++ b/gdb/f-exp.y @@ -167,7 +167,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 @@ -256,6 +256,10 @@ exp : UNOP_INTRINSIC '(' exp ')' { write_exp_elt_opcode (pstate, $1); } ; +exp : BINOP_INTRINSIC '(' exp ',' exp ')' + { write_exp_elt_opcode (pstate, $1); } + ; + arglist : ; @@ -952,7 +956,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 91bf73b800a..5eeb7dba6e5 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); @@ -323,15 +432,53 @@ 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 print_subexp_f (struct expression *exp, int *pos, @@ -347,10 +494,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; } } @@ -386,6 +546,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; } @@ -409,6 +573,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 c3176de428e..cb40108aa83 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/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\\)"