From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from simark.ca by simark.ca with LMTP id 6eVPMrH8mmqL7CgAWB0awg (envelope-from ) for ; Fri, 04 Sep 2026 13:15:29 -0400 Authentication-Results: simark.ca; dkim=pass (2048-bit key; unprotected) header.d=polymtl.ca header.i=@polymtl.ca header.a=rsa-sha256 header.s=oct2025 header.b=ECUie7YI; dkim-atps=neutral Received: by simark.ca (Postfix, from userid 112) id C91291E166; Fri, 04 Sep 2026 13:15:29 -0400 (EDT) X-Spam-Checker-Version: SpamAssassin 4.0.1 (2024-03-25) on simark.ca X-Spam-Level: X-Spam-Status: No, score=-5.4 required=5.0 tests=ARC_SIGNED,ARC_VALID,BAYES_00, DKIM_SIGNED,DKIM_VALID,DKIM_VALID_AU,MAILING_LIST_MULTI, RCVD_IN_DNSWL_MED autolearn=ham autolearn_force=no version=4.0.1 Received: from vm01.sourceware.org (vm01.sourceware.org [IPv6:2620:52:6:3111::32]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange x25519 server-signature ECDSA (prime256v1) server-digest SHA256) (No client certificate requested) by simark.ca (Postfix) with ESMTPS id 1FDA91E033 for ; Fri, 04 Sep 2026 13:15:14 -0400 (EDT) Received: from vm01.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id AB9A44BB3BFA for ; Fri, 4 Sep 2026 17:15:13 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org AB9A44BB3BFA Authentication-Results: sourceware.org; dkim=pass (2048-bit key, unprotected) header.d=polymtl.ca header.i=@polymtl.ca header.a=rsa-sha256 header.s=oct2025 header.b=ECUie7YI Received: from smtp.polymtl.ca (smtp.polymtl.ca [132.207.4.11]) by sourceware.org (Postfix) with ESMTPS id 2B6144BA2E0B for ; Fri, 4 Sep 2026 17:14:23 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 2B6144BA2E0B Authentication-Results: sourceware.org; dmarc=pass (p=none dis=none) header.from=polymtl.ca Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=polymtl.ca ARC-Filter: OpenARC Filter v1.0.0 sourceware.org 2B6144BA2E0B Authentication-Results: sourceware.org; arc=none smtp.remote-ip=132.207.4.11 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1788542063; cv=none; b=jbFt0s2m3AyIymN0Fz78pQf+M+/gi2imrPDJWeo0ECQZbdpMcJ1vu16PAT6l+dOios/Z/vyHmwrlBkTm2aKwam4FtM9boI/BrHuazgyipOhoN8+x4MM372V/NUlurC4lQlCfvmcRPh9MtB4wAOs6NHBI3ifHdBQwpA0XZMimbVo= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1788542063; c=relaxed/simple; bh=1jgq/Sb6R/2UrchxZkQrtKinqRQNjQZBtaYFLfbjvas=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=nzGmUnKCMTcwDlqYAzamWsulWpGvlRfF6MfnOr4UhzyalPgHJLf5dlvJUipD029Da8WXcE2743CK7yLGMdWRxmdYkFrlQ3ntjs1AaJmOcQ9QwGNOBdONdMTzdCp2JW82V+vmClhRUsbLO6tYA1EJl/pTagIpKSsJDGNonv8LxTU= ARC-Authentication-Results: i=1; sourceware.org; dkim=pass (2048-bit key, unprotected) header.d=polymtl.ca header.i=@polymtl.ca header.a=rsa-sha256 header.s=oct2025 header.b=ECUie7YI DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 2B6144BA2E0B Received: from simark.ca (simark.ca [158.69.221.121]) (authenticated bits=0) by smtp.polymtl.ca (8.14.7/8.14.7) with ESMTP id 684HEG5k145323 (version=TLSv1/SSLv3 cipher=ECDHE-RSA-AES256-GCM-SHA384 bits=256 verify=NOT); Fri, 4 Sep 2026 13:14:21 -0400 DKIM-Filter: OpenDKIM Filter v2.11.0 smtp.polymtl.ca 684HEG5k145323 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=polymtl.ca; s=oct2025; t=1788542061; bh=R3bPzViIEmnFZKltqnGBg3nheotkCKfm3u0MvGOE7Mc=; h=From:To:Cc:Subject:Date:In-Reply-To:From; b=ECUie7YIjDSwjul82J1JCmoDCGEPfW9pRiKX/V86ZrOsWaBU+6/cAbvW4surwUyKL XGu5cZyR5EV71rOfZhI6QNcuXESgrKG6oPN/rAWqf45lfEnUvjTSpM6PX3vgxuB+NI twjf0BdcjdQm8CsSwZYFdpxQFQIV878BxLM071bhe9MxGWxOrCo5BZ90zQdtsKF1NC UfHkOyGxV1azBrXR05UbcdbUoriuWrDdEYEcaXQE5lGpEqujCH0XSZd8QAaU+8Go/m 0frop/IsYvp279NPX6l1aws+MCoJYy5NFqKIQN8ALXot+5kVS6xVlUjfUr5qTHQFlH Az+htUTcGz0qA== Received: by simark.ca (Postfix) id F18C31E3B3; Fri, 04 Sep 2026 13:05:50 -0400 (EDT) From: simon.marchi@polymtl.ca To: gdb-patches@sourceware.org Cc: Simon Marchi Subject: [PATCH 14/17] gdb: move f-exp-parser.y's support code to f-exp-parser.c Date: Fri, 4 Sep 2026 12:56:46 -0400 Message-ID: <20260904170338.1643894-15-simon.marchi@polymtl.ca> X-Mailer: git-send-email 2.55.0 In-Reply-To: <20260904170338.1643894-1-simon.marchi@polymtl.ca> References: <20260904170338.1643894-1-simon.marchi@polymtl.ca> MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Poly-FromMTA: (simark.ca [158.69.221.121]) at Fri, 4 Sep 2026 17:14:16 +0000 X-BeenThere: gdb-patches@sourceware.org X-Mailman-Version: 2.1.30 Precedence: list List-Id: Gdb-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gdb-patches-bounces~public-inbox=simark.ca@sourceware.org From: Simon Marchi Similar to the previous commits, but for the Fortran expression parser. Since the Fortran parser is entered through the f_language::parser method rather than a free function, add a free function f_parse as the entry point (like the other parsers) and turn f_language::parser into a thin wrapper around it, defined in f-lang.c. This keeps things more consistent. Like the D parser, the Fortran parser keeps a type_stack global whose name clashes with the struct type_stack type once it lives in the namespace and is brought in with a using-directive. A using-declaration for it in the .y prologue restores the original name hiding, so the grammar actions can keep referring to it unqualified. The Fortran support code uses malloc, realloc and free directly. These used to be rewritten to their x-variants by post-process-parser-output.sh when the code was part of the generated parser. Replace them with their x-variants in the moved code. Put the parser support code inside the f_exp_parser namespace. Change-Id: Ic682bf04ff4058223d0b174effc427f5b22eeb1e --- gdb/Makefile.in | 2 + gdb/f-exp-parser.c | 989 ++++++++++++++++++++++++++++++++++++++++++++ gdb/f-exp-parser.h | 102 +++++ gdb/f-exp-parser.y | 995 +-------------------------------------------- gdb/f-lang.c | 9 + 5 files changed, 1108 insertions(+), 989 deletions(-) create mode 100644 gdb/f-exp-parser.c create mode 100644 gdb/f-exp-parser.h diff --git a/gdb/Makefile.in b/gdb/Makefile.in index f861b1f53261..0a35f9507def 100644 --- a/gdb/Makefile.in +++ b/gdb/Makefile.in @@ -1103,6 +1103,7 @@ COMMON_SFILES = \ expanded-symbol.c \ expprint.c \ extension.c \ + f-exp-parser.c \ f-lang.c \ f-typeprint.c \ f-valprint.c \ @@ -1455,6 +1456,7 @@ HFILES_NO_SRCDIR = \ filesystem.h \ find-memory-region.h \ finish-thread-state.h \ + f-exp-parser.h \ f-lang.h \ frame-base.h \ frame.h \ diff --git a/gdb/f-exp-parser.c b/gdb/f-exp-parser.c new file mode 100644 index 000000000000..9e0c7aa6650c --- /dev/null +++ b/gdb/f-exp-parser.c @@ -0,0 +1,989 @@ +/* YACC parser support code for Fortran expressions, for GDB. + + Copyright (C) 1986-2026 Free Software Foundation, Inc. + + This file is part of GDB. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . */ + +#include "f-exp-parser.h" +#include "f-exp-parser-gen.h" +#include "block.h" +#include "expression.h" +#include "f-exp.h" +#include "language.h" +#include "parser-defs.h" +#include "value.h" +#include + +/* The entry point of the bison/yacc-generated parser, defined in + f-exp-parser-gen.c. Bison produces a declaration for f_yyparse in + f-exp-parser-gen.h, but byacc does not, hence this declaration. */ + +int f_yyparse (); + +/* Likewise, byacc does not produce a declaration for f_yydebug. */ + +extern int f_yydebug; + +using namespace expr; + +namespace f_exp_parser +{ + +/* See f-exp-parser.h. */ + +parser_state *pstate; + +/* Depth of parentheses. */ + +static int paren_depth; + +/* See f-exp-parser.h. */ + +struct type_stack *type_stack; + +/* A helper that pops two operations (similar to wrap2), evaluates the last one + assuming it is a kind parameter, and wraps them in some other operation + pushing it to the stack. */ + +template +static void +fortran_wrap2_kind (type *base_type) +{ + operation_up kind_arg = pstate->pop (); + operation_up arg = pstate->pop (); + + value *val = kind_arg->evaluate (nullptr, pstate->expout.get (), + EVAL_AVOID_SIDE_EFFECTS); + gdb_assert (val != nullptr); + + type *follow_type = convert_to_kind_type (base_type, value_as_long (val)); + + pstate->push_new (std::move (arg), follow_type); +} + +/* A helper that pops three operations, evaluates the last one assuming it is a + kind parameter, and wraps them in some other operation pushing it to the + stack. */ + +template +static void +fortran_wrap3_kind (type *base_type) +{ + operation_up kind_arg = pstate->pop (); + operation_up arg2 = pstate->pop (); + operation_up arg1 = pstate->pop (); + + value *val = kind_arg->evaluate (nullptr, pstate->expout.get (), + EVAL_AVOID_SIDE_EFFECTS); + gdb_assert (val != nullptr); + + type *follow_type = convert_to_kind_type (base_type, value_as_long (val)); + + pstate->push_new (std::move (arg1), std::move (arg2), follow_type); +} + +/* See f-exp-parser.h. */ + +void +wrap_unop_intrinsic (exp_opcode code) +{ + switch (code) + { + case UNOP_ABS: + pstate->wrap (); + break; + case FORTRAN_FLOOR: + pstate->wrap (); + break; + case FORTRAN_CEILING: + pstate->wrap (); + break; + case UNOP_FORTRAN_ALLOCATED: + pstate->wrap (); + break; + case UNOP_FORTRAN_RANK: + pstate->wrap (); + break; + case UNOP_FORTRAN_SHAPE: + pstate->wrap (); + break; + case UNOP_FORTRAN_LOC: + pstate->wrap (); + break; + case FORTRAN_ASSOCIATED: + pstate->wrap (); + break; + case FORTRAN_ARRAY_SIZE: + pstate->wrap (); + break; + case FORTRAN_CMPLX: + pstate->wrap (); + break; + case FORTRAN_LBOUND: + case FORTRAN_UBOUND: + pstate->push_new (code, pstate->pop ()); + break; + default: + gdb_assert_not_reached ("unhandled intrinsic"); + } +} + +/* See f-exp-parser.h. */ + +void +wrap_binop_intrinsic (exp_opcode code) +{ + switch (code) + { + case FORTRAN_FLOOR: + fortran_wrap2_kind + (parse_f_type (pstate)->builtin_integer); + break; + case FORTRAN_CEILING: + fortran_wrap2_kind + (parse_f_type (pstate)->builtin_integer); + break; + case BINOP_MOD: + pstate->wrap2 (); + break; + case BINOP_FORTRAN_MODULO: + pstate->wrap2 (); + break; + case FORTRAN_CMPLX: + pstate->wrap2 (); + break; + case FORTRAN_ASSOCIATED: + pstate->wrap2 (); + break; + case FORTRAN_ARRAY_SIZE: + pstate->wrap2 (); + break; + case FORTRAN_LBOUND: + case FORTRAN_UBOUND: + { + operation_up arg2 = pstate->pop (); + operation_up arg1 = pstate->pop (); + pstate->push_new (code, std::move (arg1), + std::move (arg2)); + } + break; + default: + gdb_assert_not_reached ("unhandled intrinsic"); + } +} + +/* See f-exp-parser.h. */ + +void +wrap_ternop_intrinsic (exp_opcode code) +{ + switch (code) + { + case FORTRAN_LBOUND: + case FORTRAN_UBOUND: + { + operation_up kind_arg = pstate->pop (); + operation_up arg2 = pstate->pop (); + operation_up arg1 = pstate->pop (); + + value *val = kind_arg->evaluate (nullptr, pstate->expout.get (), + EVAL_AVOID_SIDE_EFFECTS); + gdb_assert (val != nullptr); + + type *follow_type + = convert_to_kind_type (parse_f_type (pstate)->builtin_integer, + value_as_long (val)); + + pstate->push_new (code, std::move (arg1), + std::move (arg2), follow_type); + } + break; + case FORTRAN_ARRAY_SIZE: + fortran_wrap3_kind + (parse_f_type (pstate)->builtin_integer); + break; + case FORTRAN_CMPLX: + fortran_wrap3_kind + (parse_f_type (pstate)->builtin_complex); + break; + default: + gdb_assert_not_reached ("unhandled intrinsic"); + } +} + +/* See f-exp-parser.h. */ + +int +parse_number (struct parser_state *par_state, + const char *p, int len, int parsed_float, + f_exp_parser_YYSTYPE *putithere) +{ + ULONGEST n = 0; + ULONGEST prevn = 0; + int c; + int base = input_radix; + int unsigned_p = 0; + int long_p = 0; + ULONGEST high_bit; + struct type *signed_type; + struct type *unsigned_type; + + if (parsed_float) + { + /* It's a float since it contains a point or an exponent. */ + /* [dD] is not understood as an exponent by parse_float, + change it to 'e'. */ + char *tmp, *tmp2; + + tmp = xstrdup (p); + for (tmp2 = tmp; *tmp2; ++tmp2) + if (*tmp2 == 'd' || *tmp2 == 'D') + *tmp2 = 'e'; + + /* FIXME: Should this use different types? */ + putithere->typed_val_float.type = parse_f_type (pstate)->builtin_real_s8; + bool parsed = parse_float (tmp, len, + putithere->typed_val_float.type, + putithere->typed_val_float.val); + xfree (tmp); + return parsed? FLOAT : ERROR; + } + + /* Handle base-switching prefixes 0x, 0t, 0d, 0 */ + if (p[0] == '0' && len > 1) + switch (p[1]) + { + case 'x': + case 'X': + if (len >= 3) + { + p += 2; + base = 16; + len -= 2; + } + break; + + case 't': + case 'T': + case 'd': + case 'D': + if (len >= 3) + { + p += 2; + base = 10; + len -= 2; + } + break; + + default: + base = 8; + break; + } + + while (len-- > 0) + { + c = *p++; + if (c_isupper (c)) + c = c_tolower (c); + if (len == 0 && c == 'l') + long_p = 1; + else if (len == 0 && c == 'u') + unsigned_p = 1; + else + { + int i; + if (c >= '0' && c <= '9') + i = c - '0'; + else if (c >= 'a' && c <= 'f') + i = c - 'a' + 10; + else + return ERROR; /* Char not a digit */ + if (i >= base) + return ERROR; /* Invalid digit in this base */ + n *= base; + n += i; + } + /* Test for overflow. */ + if (prevn == 0 && n == 0) + ; + else if (RANGE_CHECK && prevn >= n) + range_error (_("Overflow on numeric constant.")); + prevn = n; + } + + /* If the number is too big to be an int, or it's got an l suffix + then it's a long. Work out if this has to be a long by + shifting right and seeing if anything remains, and the + target int size is different to the target long size. + + In the expression below, we could have tested + (n >> gdbarch_int_bit (parse_gdbarch)) + to see if it was zero, + but too many compilers warn about that, when ints and longs + are the same size. So we shift it twice, with fewer bits + each time, for the same result. */ + + int bits_available; + if ((gdbarch_int_bit (par_state->gdbarch ()) + != gdbarch_long_bit (par_state->gdbarch ()) + && ((n >> 2) + >> (gdbarch_int_bit (par_state->gdbarch ())-2))) /* Avoid + shift warning */ + || long_p) + { + bits_available = gdbarch_long_bit (par_state->gdbarch ()); + unsigned_type = parse_type (par_state)->builtin_unsigned_long; + signed_type = parse_type (par_state)->builtin_long; + } + else + { + bits_available = gdbarch_int_bit (par_state->gdbarch ()); + unsigned_type = parse_type (par_state)->builtin_unsigned_int; + signed_type = parse_type (par_state)->builtin_int; + } + high_bit = ((ULONGEST)1) << (bits_available - 1); + + if (RANGE_CHECK + && ((n >> 2) >> (bits_available - 2))) + range_error (_("Overflow on numeric constant.")); + + putithere->typed_val.val = n; + + /* If the high bit of the worked out type is set then this number + has to be unsigned. */ + + if (unsigned_p || (n & high_bit)) + putithere->typed_val.type = unsigned_type; + else + putithere->typed_val.type = signed_type; + + return INT; +} + +/* See f-exp-parser.h. */ + +void +push_kind_type (LONGEST val, struct type *type) +{ + int ival; + + if (type->is_unsigned ()) + { + ULONGEST uval = static_cast (val); + if (uval > INT_MAX) + error (_("kind value out of range")); + ival = static_cast (uval); + } + else + { + if (val > INT_MAX || val < 0) + error (_("kind value out of range")); + ival = static_cast (val); + } + + type_stack->push (tp_kind, ival); +} + +/* Helper function for convert_to_kind_type. */ +static struct type * +convert_to_kind_type_1 (struct type *basetype, int kind) +{ + if (basetype == parse_f_type (pstate)->builtin_character) + { + /* Character of kind 1 is a special case, this is the same as the + base character type. */ + if (kind == 1) + return parse_f_type (pstate)->builtin_character; + } + else if (basetype == parse_f_type (pstate)->builtin_complex) + { + if (kind == 4) + return parse_f_type (pstate)->builtin_complex; + else if (kind == 8) + return parse_f_type (pstate)->builtin_complex_s8; + else if (kind == 16) + return parse_f_type (pstate)->builtin_complex_s16; + } + else if (basetype == parse_f_type (pstate)->builtin_real) + { + if (kind == 4) + return parse_f_type (pstate)->builtin_real; + else if (kind == 8) + return parse_f_type (pstate)->builtin_real_s8; + else if (kind == 16) + return parse_f_type (pstate)->builtin_real_s16; + } + else if (basetype == parse_f_type (pstate)->builtin_logical) + { + if (kind == 1) + return parse_f_type (pstate)->builtin_logical_s1; + else if (kind == 2) + return parse_f_type (pstate)->builtin_logical_s2; + else if (kind == 4) + return parse_f_type (pstate)->builtin_logical; + else if (kind == 8) + return parse_f_type (pstate)->builtin_logical_s8; + } + else if (basetype == parse_f_type (pstate)->builtin_integer) + { + if (kind == 1) + return parse_f_type (pstate)->builtin_integer_s1; + else if (kind == 2) + return parse_f_type (pstate)->builtin_integer_s2; + else if (kind == 4) + return parse_f_type (pstate)->builtin_integer; + else if (kind == 8) + return parse_f_type (pstate)->builtin_integer_s8; + } + + return nullptr; +} + +/* See f-exp-parser.h. */ + +struct type * +convert_to_kind_type (struct type *basetype, int kind) +{ + struct type *res = convert_to_kind_type_1 (basetype, kind); + + if (res == nullptr || res->code () == TYPE_CODE_ERROR) + error (_("unsupported kind %d for type %s"), + kind, basetype->safe_name ()); + + return res; +} + +struct f_token +{ + /* The string to match against. */ + const char *oper; + + /* The lexer token to return. */ + int token; + + /* The expression opcode to embed within the token. */ + enum exp_opcode opcode; + + /* When this is true the string in OPER is matched exactly including + case, when this is false OPER is matched case insensitively. */ + bool case_sensitive; +}; + +/* List of Fortran operators. */ + +static const struct f_token fortran_operators[] = +{ + { ".and.", BOOL_AND, OP_NULL, false }, + { ".or.", BOOL_OR, OP_NULL, false }, + { ".not.", BOOL_NOT, OP_NULL, false }, + { ".eq.", EQUAL, OP_NULL, false }, + { ".eqv.", EQUAL, OP_NULL, false }, + { ".neqv.", NOTEQUAL, OP_NULL, false }, + { ".xor.", NOTEQUAL, OP_NULL, false }, + { "==", EQUAL, OP_NULL, false }, + { ".ne.", NOTEQUAL, OP_NULL, false }, + { "/=", NOTEQUAL, OP_NULL, false }, + { ".le.", LEQ, OP_NULL, false }, + { "<=", LEQ, OP_NULL, false }, + { ".ge.", GEQ, OP_NULL, false }, + { ">=", GEQ, OP_NULL, false }, + { ".gt.", GREATERTHAN, OP_NULL, false }, + { ">", GREATERTHAN, OP_NULL, false }, + { ".lt.", LESSTHAN, OP_NULL, false }, + { "<", LESSTHAN, OP_NULL, false }, + { "**", STARSTAR, BINOP_EXP, false }, +}; + +/* Holds the Fortran representation of a boolean, and the integer value we + substitute in when one of the matching strings is parsed. */ +struct f77_boolean_val +{ + /* The string representing a Fortran boolean. */ + const char *name; + + /* The integer value to replace it with. */ + int value; +}; + +/* The set of Fortran booleans. These are matched case insensitively. */ +static const struct f77_boolean_val boolean_values[] = +{ + { ".true.", 1 }, + { ".false.", 0 } +}; + +static const struct f_token f_intrinsics[] = +{ + /* The following correspond to actual functions in Fortran and are case + insensitive. */ + { "kind", KIND, OP_NULL, false }, + { "abs", UNOP_INTRINSIC, UNOP_ABS, false }, + { "mod", BINOP_INTRINSIC, BINOP_MOD, false }, + { "floor", UNOP_OR_BINOP_INTRINSIC, FORTRAN_FLOOR, false }, + { "ceiling", UNOP_OR_BINOP_INTRINSIC, FORTRAN_CEILING, false }, + { "modulo", BINOP_INTRINSIC, BINOP_FORTRAN_MODULO, false }, + { "cmplx", UNOP_OR_BINOP_OR_TERNOP_INTRINSIC, FORTRAN_CMPLX, false }, + { "lbound", UNOP_OR_BINOP_OR_TERNOP_INTRINSIC, FORTRAN_LBOUND, false }, + { "ubound", UNOP_OR_BINOP_OR_TERNOP_INTRINSIC, FORTRAN_UBOUND, false }, + { "allocated", UNOP_INTRINSIC, UNOP_FORTRAN_ALLOCATED, false }, + { "associated", UNOP_OR_BINOP_INTRINSIC, FORTRAN_ASSOCIATED, false }, + { "rank", UNOP_INTRINSIC, UNOP_FORTRAN_RANK, false }, + { "size", UNOP_OR_BINOP_OR_TERNOP_INTRINSIC, FORTRAN_ARRAY_SIZE, false }, + { "shape", UNOP_INTRINSIC, UNOP_FORTRAN_SHAPE, false }, + { "loc", UNOP_INTRINSIC, UNOP_FORTRAN_LOC, false }, + { "sizeof", SIZEOF, OP_NULL, false }, +}; + +static const f_token f_keywords[] = +{ + /* Historically these have always been lowercase only in GDB. */ + { "character", CHARACTER, OP_NULL, true }, + { "complex", COMPLEX_KEYWORD, OP_NULL, true }, + { "complex_4", COMPLEX_S4_KEYWORD, OP_NULL, true }, + { "complex_8", COMPLEX_S8_KEYWORD, OP_NULL, true }, + { "complex_16", COMPLEX_S16_KEYWORD, OP_NULL, true }, + { "integer_1", INT_S1_KEYWORD, OP_NULL, true }, + { "integer_2", INT_S2_KEYWORD, OP_NULL, true }, + { "integer_4", INT_S4_KEYWORD, OP_NULL, true }, + { "integer", INT_KEYWORD, OP_NULL, true }, + { "integer_8", INT_S8_KEYWORD, OP_NULL, true }, + { "logical_1", LOGICAL_S1_KEYWORD, OP_NULL, true }, + { "logical_2", LOGICAL_S2_KEYWORD, OP_NULL, true }, + { "logical", LOGICAL_KEYWORD, OP_NULL, true }, + { "logical_4", LOGICAL_S4_KEYWORD, OP_NULL, true }, + { "logical_8", LOGICAL_S8_KEYWORD, OP_NULL, true }, + { "real", REAL_KEYWORD, OP_NULL, true }, + { "real_4", REAL_S4_KEYWORD, OP_NULL, true }, + { "real_8", REAL_S8_KEYWORD, OP_NULL, true }, + { "real_16", REAL_S16_KEYWORD, OP_NULL, true }, + { "single", SINGLE, OP_NULL, true }, + { "double", DOUBLE, OP_NULL, true }, + { "precision", PRECISION, OP_NULL, true }, +}; + +/* Implementation of a dynamically expandable buffer for processing input + characters acquired through lexptr and building a value to return in + yylval. Ripped off from ch-exp.y */ + +static char *tempbuf; /* Current buffer contents */ +static int tempbufsize; /* Size of allocated buffer */ +static int tempbufindex; /* Current index into buffer */ + +#define GROWBY_MIN_SIZE 64 /* Minimum amount to grow buffer by */ + +#define CHECKBUF(size) \ + do { \ + if (tempbufindex + (size) >= tempbufsize) \ + { \ + growbuf_by_size (size); \ + } \ + } while (0); + +/* Grow the static temp buffer if necessary, including allocating the + first one on demand. */ + +static void +growbuf_by_size (int count) +{ + int growby; + + growby = std::max (count, GROWBY_MIN_SIZE); + tempbufsize += growby; + if (tempbuf == NULL) + tempbuf = (char *) xmalloc (tempbufsize); + else + tempbuf = (char *) xrealloc (tempbuf, tempbufsize); +} + +/* Blatantly ripped off from ch-exp.y. This routine recognizes F77 + string-literals. + + Recognize a string literal. A string literal is a nonzero sequence + of characters enclosed in matching single quotes, except that + a single character inside single quotes is a character literal, which + we reject as a string literal. To embed the terminator character inside + a string, it is simply doubled (I.E. 'this''is''one''string') */ + +static int +match_string_literal (void) +{ + const char *tokptr = pstate->lexptr; + + for (tempbufindex = 0, tokptr++; *tokptr != '\0'; tokptr++) + { + CHECKBUF (1); + if (*tokptr == *pstate->lexptr) + { + if (*(tokptr + 1) == *pstate->lexptr) + tokptr++; + else + break; + } + tempbuf[tempbufindex++] = *tokptr; + } + if (*tokptr == '\0' /* no terminator */ + || tempbufindex == 0) /* no string */ + return 0; + else + { + tempbuf[tempbufindex] = '\0'; + f_yylval.sval.ptr = tempbuf; + f_yylval.sval.length = tempbufindex; + pstate->lexptr = ++tokptr; + return STRING_LITERAL; + } +} + +/* This is set if a NAME token appeared at the very end of the input + string, with no whitespace separating the name from the EOF. This + is used only when parsing to do field name completion. */ +static bool saw_name_at_eof; + +/* This is set if the previously-returned token was a structure + operator '%'. */ +static bool last_was_structop; + +/* See f-exp-parser.h. */ + +int +f_yylex (void) +{ + int c; + int namelen; + unsigned int token; + const char *tokstart; + bool saw_structop = last_was_structop; + + last_was_structop = false; + + retry: + + pstate->prev_lexptr = pstate->lexptr; + + tokstart = pstate->lexptr; + + /* First of all, let us make sure we are not dealing with the + special tokens .true. and .false. which evaluate to 1 and 0. */ + + if (*pstate->lexptr == '.') + { + for (const auto &candidate : boolean_values) + { + if (strncasecmp (tokstart, candidate.name, + strlen (candidate.name)) == 0) + { + pstate->lexptr += strlen (candidate.name); + f_yylval.lval = candidate.value; + return BOOLEAN_LITERAL; + } + } + } + + /* See if it is a Fortran operator. */ + for (const auto &candidate : fortran_operators) + if (strncasecmp (tokstart, candidate.oper, + strlen (candidate.oper)) == 0) + { + gdb_assert (!candidate.case_sensitive); + pstate->lexptr += strlen (candidate.oper); + f_yylval.opcode = candidate.opcode; + return candidate.token; + } + + switch (c = *tokstart) + { + case 0: + if (saw_name_at_eof) + { + saw_name_at_eof = false; + return COMPLETE; + } + else if (pstate->parse_completion && saw_structop) + return COMPLETE; + return 0; + + case ' ': + case '\t': + case '\n': + pstate->lexptr++; + goto retry; + + case '\'': + token = match_string_literal (); + if (token != 0) + return (token); + break; + + case '(': + paren_depth++; + pstate->lexptr++; + return c; + + case ')': + if (paren_depth == 0) + return 0; + paren_depth--; + pstate->lexptr++; + return c; + + case ',': + if (pstate->comma_terminates && paren_depth == 0) + return 0; + pstate->lexptr++; + return c; + + case '.': + /* Might be a floating point number. */ + if (pstate->lexptr[1] < '0' || pstate->lexptr[1] > '9') + goto symbol; /* Nope, must be a symbol. */ + [[fallthrough]]; + + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + { + /* It's a number. */ + int got_dot = 0, got_e = 0, got_d = 0, toktype; + const char *p = tokstart; + int hex = input_radix > 10; + + if (c == '0' && (p[1] == 'x' || p[1] == 'X')) + { + p += 2; + hex = 1; + } + else if (c == '0' && (p[1]=='t' || p[1]=='T' + || p[1]=='d' || p[1]=='D')) + { + p += 2; + hex = 0; + } + + for (;; ++p) + { + if (!hex && !got_e && (*p == 'e' || *p == 'E')) + got_dot = got_e = 1; + else if (!hex && !got_d && (*p == 'd' || *p == 'D')) + got_dot = got_d = 1; + else if (!hex && !got_dot && *p == '.') + got_dot = 1; + else if (((got_e && (p[-1] == 'e' || p[-1] == 'E')) + || (got_d && (p[-1] == 'd' || p[-1] == 'D'))) + && (*p == '-' || *p == '+')) + /* This is the sign of the exponent, not the end of the + number. */ + continue; + /* We will take any letters or digits. parse_number will + complain if past the radix, or if L or U are not final. */ + else if ((*p < '0' || *p > '9') + && ((*p < 'a' || *p > 'z') + && (*p < 'A' || *p > 'Z'))) + break; + } + toktype = parse_number (pstate, tokstart, p - tokstart, + got_dot|got_e|got_d, + &f_yylval); + if (toktype == ERROR) + error (_("Invalid number \"%.*s\"."), (int) (p - tokstart), + tokstart); + pstate->lexptr = p; + return toktype; + } + + case '%': + last_was_structop = true; + [[fallthrough]]; + case '+': + case '-': + case '*': + case '/': + case '|': + case '&': + case '^': + case '~': + case '!': + case '@': + case '<': + case '>': + case '[': + case ']': + case '?': + case ':': + case '=': + case '{': + case '}': + symbol: + pstate->lexptr++; + return c; + } + + if (!(c == '_' || c == '$' || c ==':' + || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'))) + /* We must have come across a bad character (e.g. ';'). */ + error (_("Invalid character '%c' in expression."), c); + + namelen = 0; + for (c = tokstart[namelen]; + (c == '_' || c == '$' || c == ':' || (c >= '0' && c <= '9') + || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')); + c = tokstart[++namelen]); + + /* The token "if" terminates the expression and is NOT + removed from the input stream. */ + + if (namelen == 2 && tokstart[0] == 'i' && tokstart[1] == 'f') + return 0; + + pstate->lexptr += namelen; + + /* Catch specific keywords. */ + + for (const auto &keyword : f_keywords) + if (strlen (keyword.oper) == namelen + && ((!keyword.case_sensitive + && strncasecmp (tokstart, keyword.oper, namelen) == 0) + || (keyword.case_sensitive + && strncmp (tokstart, keyword.oper, namelen) == 0))) + { + f_yylval.opcode = keyword.opcode; + return keyword.token; + } + + f_yylval.sval.ptr = tokstart; + f_yylval.sval.length = namelen; + + if (*tokstart == '$') + return DOLLAR_VARIABLE; + + /* Use token-type TYPENAME for symbols that happen to be defined + currently as names of types; NAME for other symbols. + The caller is not constrained to care about the distinction. */ + { + std::string tmp = copy_name (f_yylval.sval); + struct block_symbol result; + const domain_search_flags lookup_domains[] = + { + SEARCH_VFT, + SEARCH_STRUCT_DOMAIN, + SEARCH_MODULE_DOMAIN + }; + int hextype; + + for (const auto &domain : lookup_domains) + { + result = lookup_symbol (tmp.c_str (), pstate->expression_context_block, + domain, NULL); + if (result.symbol && result.symbol->loc_class () == LOC_TYPEDEF) + { + f_yylval.tsym.type = result.symbol->type (); + return TYPENAME; + } + + if (result.symbol) + break; + } + + f_yylval.tsym.type + = language_lookup_primitive_type (pstate->language (), + pstate->gdbarch (), tmp.c_str ()); + if (f_yylval.tsym.type != NULL) + return TYPENAME; + + /* This is post the symbol search as symbols can hide intrinsics. Also, + give Fortran intrinsics priority over C symbols. This prevents + non-Fortran symbols from hiding intrinsics, for example abs. */ + if (!result.symbol || result.symbol->language () != language_fortran) + for (const auto &intrinsic : f_intrinsics) + { + gdb_assert (!intrinsic.case_sensitive); + if (strlen (intrinsic.oper) == namelen + && strncasecmp (tokstart, intrinsic.oper, namelen) == 0) + { + f_yylval.opcode = intrinsic.opcode; + return intrinsic.token; + } + } + + /* Input names that aren't symbols but ARE valid hex numbers, + when the input radix permits them, can be names or numbers + depending on the parse. Note we support radixes > 16 here. */ + if (!result.symbol + && ((tokstart[0] >= 'a' && tokstart[0] < 'a' + input_radix - 10) + || (tokstart[0] >= 'A' && tokstart[0] < 'A' + input_radix - 10))) + { + f_exp_parser_YYSTYPE newlval; /* Its value is ignored. */ + hextype = parse_number (pstate, tokstart, namelen, 0, &newlval); + if (hextype == INT) + { + f_yylval.ssym.sym = result; + f_yylval.ssym.is_a_field_of_this = false; + return NAME_OR_INT; + } + } + + if (pstate->parse_completion && *pstate->lexptr == '\0') + saw_name_at_eof = true; + + /* Any other kind of symbol */ + f_yylval.ssym.sym = result; + f_yylval.ssym.is_a_field_of_this = false; + return NAME; + } +} + +/* See f-exp-parser.h. */ + +void +f_yyerror (const char *msg) +{ + pstate->parse_error (msg); +} + +} /* namespace f_exp_parser */ + +/* See f-exp-parser.h. */ + +int +f_parse (struct parser_state *par_state) +{ + using namespace f_exp_parser; + + /* Setting up the parser state. */ + scoped_restore pstate_restore = make_scoped_restore (&pstate); + scoped_restore restore_yydebug = make_scoped_restore (&f_yydebug, + par_state->debug); + gdb_assert (par_state != NULL); + pstate = par_state; + last_was_structop = false; + saw_name_at_eof = false; + paren_depth = 0; + + struct type_stack stack; + scoped_restore restore_type_stack + = make_scoped_restore (&f_exp_parser::type_stack, &stack); + + int result = f_yyparse (); + if (!result) + pstate->set_operation (pstate->pop ()); + return result; +} diff --git a/gdb/f-exp-parser.h b/gdb/f-exp-parser.h new file mode 100644 index 000000000000..8f504b6e8a85 --- /dev/null +++ b/gdb/f-exp-parser.h @@ -0,0 +1,102 @@ +/* YACC parser support code for Fortran expressions, for GDB. + + Copyright (C) 1986-2026 Free Software Foundation, Inc. + + This file is part of GDB. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . */ + +#ifndef GDB_F_EXP_PARSER_H +#define GDB_F_EXP_PARSER_H + +#include "parser-defs.h" +#include "type-stack.h" +#include "f-lang.h" + +union f_exp_parser_YYSTYPE; + +namespace f_exp_parser { + +/* The state of the parser, used internally when we are parsing the + expression. */ + +extern parser_state *pstate; + +/* The current type stack. */ + +extern struct type_stack *type_stack; + +/* Return the Fortran type table for the architecture associated to PS. */ + +static inline const struct builtin_f_type * +parse_f_type (parser_state *ps) +{ + return builtin_f_type (ps->gdbarch ()); +} + +/* Called to match intrinsic function calls with one argument to their + respective implementation and push the operation. */ + +void wrap_unop_intrinsic (exp_opcode opcode); + +/* Called to match intrinsic function calls with two arguments to their + respective implementation and push the operation. */ + +void wrap_binop_intrinsic (exp_opcode opcode); + +/* Called to match intrinsic function calls with three arguments to their + respective implementation and push the operation. */ + +void wrap_ternop_intrinsic (exp_opcode opcode); + +/* Take care of parsing a number (anything that starts with a digit). + Set yylval and return the token type; update lexptr. + LEN is the number of characters in it. */ + +/*** Needs some error checking for the float case ***/ + +int parse_number (struct parser_state *par_state, const char *p, int len, + int parsed_float, f_exp_parser_YYSTYPE *putithere); + +/* Called to setup the type stack when we encounter a '(kind=N)' type + modifier, performs some bounds checking on 'N' and then pushes this to + the type stack followed by the 'tp_kind' marker. */ + +void push_kind_type (LONGEST val, struct type *type); + +/* Called when a type has a '(kind=N)' modifier after it, for example + 'character(kind=1)'. The BASETYPE is the type described by 'character' + in our example, and KIND is the integer '1'. This function returns a + new type that represents the basetype of a specific kind. */ + +struct type *convert_to_kind_type (struct type *basetype, int kind); + +/* Read one token, getting characters through lexptr. */ + +int f_yylex (); + +/* The error handler invoked by the generated parser. Report MSG as a + parse error on the current parser state. */ + +void f_yyerror (const char *msg); + +} /* namespace f_exp_parser */ + +/* Parse a Fortran expression using the lexer input and context held in + PAR_STATE. On success, return 0 and leave the resulting operation set + on PAR_STATE. On failure, return non-zero. */ + +int f_parse (struct parser_state *par_state); + +#endif /* GDB_F_EXP_PARSER_H */ diff --git a/gdb/f-exp-parser.y b/gdb/f-exp-parser.y index ad1a9253d7f9..6c252cb3eb92 100644 --- a/gdb/f-exp-parser.y +++ b/gdb/f-exp-parser.y @@ -47,57 +47,18 @@ #include "parser-defs.h" #include "language.h" #include "f-lang.h" +#include "f-exp-parser.h" #include "block.h" #include #include "type-stack.h" #include "f-exp.h" -/* The state of the parser, used internally when we are parsing the - expression. */ - -static struct parser_state *pstate = NULL; - -/* Depth of parentheses. */ -static int paren_depth; - -/* The current type stack. */ -static struct type_stack *type_stack; - -int yyparse (void); - -static int yylex (void); - -static void yyerror (const char *); - -static void growbuf_by_size (int); - -static int match_string_literal (void); - -static void push_kind_type (LONGEST val, struct type *type); - -static struct type *convert_to_kind_type (struct type *basetype, int kind); - -static void wrap_unop_intrinsic (exp_opcode opcode); - -static void wrap_binop_intrinsic (exp_opcode opcode); - -static void wrap_ternop_intrinsic (exp_opcode opcode); - -template -static void fortran_wrap2_kind (type *base_type); - -template -static void fortran_wrap3_kind (type *base_type); - -/* Return the Fortran type table for the architecture associated to PS. */ - -static inline const struct builtin_f_type * -parse_f_type (parser_state *ps) -{ - return builtin_f_type (ps->gdbarch ()); -} - +using namespace f_exp_parser; using namespace expr; + +/* Bring the f_exp_parser::type_stack global into this scope, so that it hides + the struct type_stack type name. */ +using f_exp_parser::type_stack; %} /* Although the yacc "value" of an expression is not used, @@ -128,12 +89,6 @@ using namespace expr; int *ivec; } -%{ -/* YYSTYPE gets defined by %union */ -static int parse_number (struct parser_state *, const char *, int, - int, YYSTYPE *); -%} - %type exp type_exp start variable %type type typebase %type nonempty_typelist @@ -809,941 +764,3 @@ name_not_typename : NAME | NAME_OR_INT */ ; - -%% - -/* Called to match intrinsic function calls with one argument to their - respective implementation and push the operation. */ - -static void -wrap_unop_intrinsic (exp_opcode code) -{ - switch (code) - { - case UNOP_ABS: - pstate->wrap (); - break; - case FORTRAN_FLOOR: - pstate->wrap (); - break; - case FORTRAN_CEILING: - pstate->wrap (); - break; - case UNOP_FORTRAN_ALLOCATED: - pstate->wrap (); - break; - case UNOP_FORTRAN_RANK: - pstate->wrap (); - break; - case UNOP_FORTRAN_SHAPE: - pstate->wrap (); - break; - case UNOP_FORTRAN_LOC: - pstate->wrap (); - break; - case FORTRAN_ASSOCIATED: - pstate->wrap (); - break; - case FORTRAN_ARRAY_SIZE: - pstate->wrap (); - break; - case FORTRAN_CMPLX: - pstate->wrap (); - break; - case FORTRAN_LBOUND: - case FORTRAN_UBOUND: - pstate->push_new (code, pstate->pop ()); - break; - default: - gdb_assert_not_reached ("unhandled intrinsic"); - } -} - -/* Called to match intrinsic function calls with two arguments to their - respective implementation and push the operation. */ - -static void -wrap_binop_intrinsic (exp_opcode code) -{ - switch (code) - { - case FORTRAN_FLOOR: - fortran_wrap2_kind - (parse_f_type (pstate)->builtin_integer); - break; - case FORTRAN_CEILING: - fortran_wrap2_kind - (parse_f_type (pstate)->builtin_integer); - break; - case BINOP_MOD: - pstate->wrap2 (); - break; - case BINOP_FORTRAN_MODULO: - pstate->wrap2 (); - break; - case FORTRAN_CMPLX: - pstate->wrap2 (); - break; - case FORTRAN_ASSOCIATED: - pstate->wrap2 (); - break; - case FORTRAN_ARRAY_SIZE: - pstate->wrap2 (); - break; - case FORTRAN_LBOUND: - case FORTRAN_UBOUND: - { - operation_up arg2 = pstate->pop (); - operation_up arg1 = pstate->pop (); - pstate->push_new (code, std::move (arg1), - std::move (arg2)); - } - break; - default: - gdb_assert_not_reached ("unhandled intrinsic"); - } -} - -/* Called to match intrinsic function calls with three arguments to their - respective implementation and push the operation. */ - -static void -wrap_ternop_intrinsic (exp_opcode code) -{ - switch (code) - { - case FORTRAN_LBOUND: - case FORTRAN_UBOUND: - { - operation_up kind_arg = pstate->pop (); - operation_up arg2 = pstate->pop (); - operation_up arg1 = pstate->pop (); - - value *val = kind_arg->evaluate (nullptr, pstate->expout.get (), - EVAL_AVOID_SIDE_EFFECTS); - gdb_assert (val != nullptr); - - type *follow_type - = convert_to_kind_type (parse_f_type (pstate)->builtin_integer, - value_as_long (val)); - - pstate->push_new (code, std::move (arg1), - std::move (arg2), follow_type); - } - break; - case FORTRAN_ARRAY_SIZE: - fortran_wrap3_kind - (parse_f_type (pstate)->builtin_integer); - break; - case FORTRAN_CMPLX: - fortran_wrap3_kind - (parse_f_type (pstate)->builtin_complex); - break; - default: - gdb_assert_not_reached ("unhandled intrinsic"); - } -} - -/* A helper that pops two operations (similar to wrap2), evaluates the last one - assuming it is a kind parameter, and wraps them in some other operation - pushing it to the stack. */ - -template -static void -fortran_wrap2_kind (type *base_type) -{ - operation_up kind_arg = pstate->pop (); - operation_up arg = pstate->pop (); - - value *val = kind_arg->evaluate (nullptr, pstate->expout.get (), - EVAL_AVOID_SIDE_EFFECTS); - gdb_assert (val != nullptr); - - type *follow_type = convert_to_kind_type (base_type, value_as_long (val)); - - pstate->push_new (std::move (arg), follow_type); -} - -/* A helper that pops three operations, evaluates the last one assuming it is a - kind parameter, and wraps them in some other operation pushing it to the - stack. */ - -template -static void -fortran_wrap3_kind (type *base_type) -{ - operation_up kind_arg = pstate->pop (); - operation_up arg2 = pstate->pop (); - operation_up arg1 = pstate->pop (); - - value *val = kind_arg->evaluate (nullptr, pstate->expout.get (), - EVAL_AVOID_SIDE_EFFECTS); - gdb_assert (val != nullptr); - - type *follow_type = convert_to_kind_type (base_type, value_as_long (val)); - - pstate->push_new (std::move (arg1), std::move (arg2), follow_type); -} - -/* Take care of parsing a number (anything that starts with a digit). - Set yylval and return the token type; update lexptr. - LEN is the number of characters in it. */ - -/*** Needs some error checking for the float case ***/ - -static int -parse_number (struct parser_state *par_state, - const char *p, int len, int parsed_float, YYSTYPE *putithere) -{ - ULONGEST n = 0; - ULONGEST prevn = 0; - int c; - int base = input_radix; - int unsigned_p = 0; - int long_p = 0; - ULONGEST high_bit; - struct type *signed_type; - struct type *unsigned_type; - - if (parsed_float) - { - /* It's a float since it contains a point or an exponent. */ - /* [dD] is not understood as an exponent by parse_float, - change it to 'e'. */ - char *tmp, *tmp2; - - tmp = xstrdup (p); - for (tmp2 = tmp; *tmp2; ++tmp2) - if (*tmp2 == 'd' || *tmp2 == 'D') - *tmp2 = 'e'; - - /* FIXME: Should this use different types? */ - putithere->typed_val_float.type = parse_f_type (pstate)->builtin_real_s8; - bool parsed = parse_float (tmp, len, - putithere->typed_val_float.type, - putithere->typed_val_float.val); - free (tmp); - return parsed? FLOAT : ERROR; - } - - /* Handle base-switching prefixes 0x, 0t, 0d, 0 */ - if (p[0] == '0' && len > 1) - switch (p[1]) - { - case 'x': - case 'X': - if (len >= 3) - { - p += 2; - base = 16; - len -= 2; - } - break; - - case 't': - case 'T': - case 'd': - case 'D': - if (len >= 3) - { - p += 2; - base = 10; - len -= 2; - } - break; - - default: - base = 8; - break; - } - - while (len-- > 0) - { - c = *p++; - if (c_isupper (c)) - c = c_tolower (c); - if (len == 0 && c == 'l') - long_p = 1; - else if (len == 0 && c == 'u') - unsigned_p = 1; - else - { - int i; - if (c >= '0' && c <= '9') - i = c - '0'; - else if (c >= 'a' && c <= 'f') - i = c - 'a' + 10; - else - return ERROR; /* Char not a digit */ - if (i >= base) - return ERROR; /* Invalid digit in this base */ - n *= base; - n += i; - } - /* Test for overflow. */ - if (prevn == 0 && n == 0) - ; - else if (RANGE_CHECK && prevn >= n) - range_error (_("Overflow on numeric constant.")); - prevn = n; - } - - /* If the number is too big to be an int, or it's got an l suffix - then it's a long. Work out if this has to be a long by - shifting right and seeing if anything remains, and the - target int size is different to the target long size. - - In the expression below, we could have tested - (n >> gdbarch_int_bit (parse_gdbarch)) - to see if it was zero, - but too many compilers warn about that, when ints and longs - are the same size. So we shift it twice, with fewer bits - each time, for the same result. */ - - int bits_available; - if ((gdbarch_int_bit (par_state->gdbarch ()) - != gdbarch_long_bit (par_state->gdbarch ()) - && ((n >> 2) - >> (gdbarch_int_bit (par_state->gdbarch ())-2))) /* Avoid - shift warning */ - || long_p) - { - bits_available = gdbarch_long_bit (par_state->gdbarch ()); - unsigned_type = parse_type (par_state)->builtin_unsigned_long; - signed_type = parse_type (par_state)->builtin_long; - } - else - { - bits_available = gdbarch_int_bit (par_state->gdbarch ()); - unsigned_type = parse_type (par_state)->builtin_unsigned_int; - signed_type = parse_type (par_state)->builtin_int; - } - high_bit = ((ULONGEST)1) << (bits_available - 1); - - if (RANGE_CHECK - && ((n >> 2) >> (bits_available - 2))) - range_error (_("Overflow on numeric constant.")); - - putithere->typed_val.val = n; - - /* If the high bit of the worked out type is set then this number - has to be unsigned. */ - - if (unsigned_p || (n & high_bit)) - putithere->typed_val.type = unsigned_type; - else - putithere->typed_val.type = signed_type; - - return INT; -} - -/* Called to setup the type stack when we encounter a '(kind=N)' type - modifier, performs some bounds checking on 'N' and then pushes this to - the type stack followed by the 'tp_kind' marker. */ -static void -push_kind_type (LONGEST val, struct type *type) -{ - int ival; - - if (type->is_unsigned ()) - { - ULONGEST uval = static_cast (val); - if (uval > INT_MAX) - error (_("kind value out of range")); - ival = static_cast (uval); - } - else - { - if (val > INT_MAX || val < 0) - error (_("kind value out of range")); - ival = static_cast (val); - } - - type_stack->push (tp_kind, ival); -} - -/* Helper function for convert_to_kind_type. */ -static struct type * -convert_to_kind_type_1 (struct type *basetype, int kind) -{ - if (basetype == parse_f_type (pstate)->builtin_character) - { - /* Character of kind 1 is a special case, this is the same as the - base character type. */ - if (kind == 1) - return parse_f_type (pstate)->builtin_character; - } - else if (basetype == parse_f_type (pstate)->builtin_complex) - { - if (kind == 4) - return parse_f_type (pstate)->builtin_complex; - else if (kind == 8) - return parse_f_type (pstate)->builtin_complex_s8; - else if (kind == 16) - return parse_f_type (pstate)->builtin_complex_s16; - } - else if (basetype == parse_f_type (pstate)->builtin_real) - { - if (kind == 4) - return parse_f_type (pstate)->builtin_real; - else if (kind == 8) - return parse_f_type (pstate)->builtin_real_s8; - else if (kind == 16) - return parse_f_type (pstate)->builtin_real_s16; - } - else if (basetype == parse_f_type (pstate)->builtin_logical) - { - if (kind == 1) - return parse_f_type (pstate)->builtin_logical_s1; - else if (kind == 2) - return parse_f_type (pstate)->builtin_logical_s2; - else if (kind == 4) - return parse_f_type (pstate)->builtin_logical; - else if (kind == 8) - return parse_f_type (pstate)->builtin_logical_s8; - } - else if (basetype == parse_f_type (pstate)->builtin_integer) - { - if (kind == 1) - return parse_f_type (pstate)->builtin_integer_s1; - else if (kind == 2) - return parse_f_type (pstate)->builtin_integer_s2; - else if (kind == 4) - return parse_f_type (pstate)->builtin_integer; - else if (kind == 8) - return parse_f_type (pstate)->builtin_integer_s8; - } - - return nullptr; -} - -/* Called when a type has a '(kind=N)' modifier after it, for example - 'character(kind=1)'. The BASETYPE is the type described by 'character' - in our example, and KIND is the integer '1'. This function returns a - new type that represents the basetype of a specific kind. */ -static struct type * -convert_to_kind_type (struct type *basetype, int kind) -{ - struct type *res = convert_to_kind_type_1 (basetype, kind); - - if (res == nullptr || res->code () == TYPE_CODE_ERROR) - error (_("unsupported kind %d for type %s"), - kind, basetype->safe_name ()); - - return res; -} - -struct f_token -{ - /* The string to match against. */ - const char *oper; - - /* The lexer token to return. */ - int token; - - /* The expression opcode to embed within the token. */ - enum exp_opcode opcode; - - /* When this is true the string in OPER is matched exactly including - case, when this is false OPER is matched case insensitively. */ - bool case_sensitive; -}; - -/* List of Fortran operators. */ - -static const struct f_token fortran_operators[] = -{ - { ".and.", BOOL_AND, OP_NULL, false }, - { ".or.", BOOL_OR, OP_NULL, false }, - { ".not.", BOOL_NOT, OP_NULL, false }, - { ".eq.", EQUAL, OP_NULL, false }, - { ".eqv.", EQUAL, OP_NULL, false }, - { ".neqv.", NOTEQUAL, OP_NULL, false }, - { ".xor.", NOTEQUAL, OP_NULL, false }, - { "==", EQUAL, OP_NULL, false }, - { ".ne.", NOTEQUAL, OP_NULL, false }, - { "/=", NOTEQUAL, OP_NULL, false }, - { ".le.", LEQ, OP_NULL, false }, - { "<=", LEQ, OP_NULL, false }, - { ".ge.", GEQ, OP_NULL, false }, - { ">=", GEQ, OP_NULL, false }, - { ".gt.", GREATERTHAN, OP_NULL, false }, - { ">", GREATERTHAN, OP_NULL, false }, - { ".lt.", LESSTHAN, OP_NULL, false }, - { "<", LESSTHAN, OP_NULL, false }, - { "**", STARSTAR, BINOP_EXP, false }, -}; - -/* Holds the Fortran representation of a boolean, and the integer value we - substitute in when one of the matching strings is parsed. */ -struct f77_boolean_val -{ - /* The string representing a Fortran boolean. */ - const char *name; - - /* The integer value to replace it with. */ - int value; -}; - -/* The set of Fortran booleans. These are matched case insensitively. */ -static const struct f77_boolean_val boolean_values[] = -{ - { ".true.", 1 }, - { ".false.", 0 } -}; - -static const struct f_token f_intrinsics[] = -{ - /* The following correspond to actual functions in Fortran and are case - insensitive. */ - { "kind", KIND, OP_NULL, false }, - { "abs", UNOP_INTRINSIC, UNOP_ABS, false }, - { "mod", BINOP_INTRINSIC, BINOP_MOD, false }, - { "floor", UNOP_OR_BINOP_INTRINSIC, FORTRAN_FLOOR, false }, - { "ceiling", UNOP_OR_BINOP_INTRINSIC, FORTRAN_CEILING, false }, - { "modulo", BINOP_INTRINSIC, BINOP_FORTRAN_MODULO, false }, - { "cmplx", UNOP_OR_BINOP_OR_TERNOP_INTRINSIC, FORTRAN_CMPLX, false }, - { "lbound", UNOP_OR_BINOP_OR_TERNOP_INTRINSIC, FORTRAN_LBOUND, false }, - { "ubound", UNOP_OR_BINOP_OR_TERNOP_INTRINSIC, FORTRAN_UBOUND, false }, - { "allocated", UNOP_INTRINSIC, UNOP_FORTRAN_ALLOCATED, false }, - { "associated", UNOP_OR_BINOP_INTRINSIC, FORTRAN_ASSOCIATED, false }, - { "rank", UNOP_INTRINSIC, UNOP_FORTRAN_RANK, false }, - { "size", UNOP_OR_BINOP_OR_TERNOP_INTRINSIC, FORTRAN_ARRAY_SIZE, false }, - { "shape", UNOP_INTRINSIC, UNOP_FORTRAN_SHAPE, false }, - { "loc", UNOP_INTRINSIC, UNOP_FORTRAN_LOC, false }, - { "sizeof", SIZEOF, OP_NULL, false }, -}; - -static const f_token f_keywords[] = -{ - /* Historically these have always been lowercase only in GDB. */ - { "character", CHARACTER, OP_NULL, true }, - { "complex", COMPLEX_KEYWORD, OP_NULL, true }, - { "complex_4", COMPLEX_S4_KEYWORD, OP_NULL, true }, - { "complex_8", COMPLEX_S8_KEYWORD, OP_NULL, true }, - { "complex_16", COMPLEX_S16_KEYWORD, OP_NULL, true }, - { "integer_1", INT_S1_KEYWORD, OP_NULL, true }, - { "integer_2", INT_S2_KEYWORD, OP_NULL, true }, - { "integer_4", INT_S4_KEYWORD, OP_NULL, true }, - { "integer", INT_KEYWORD, OP_NULL, true }, - { "integer_8", INT_S8_KEYWORD, OP_NULL, true }, - { "logical_1", LOGICAL_S1_KEYWORD, OP_NULL, true }, - { "logical_2", LOGICAL_S2_KEYWORD, OP_NULL, true }, - { "logical", LOGICAL_KEYWORD, OP_NULL, true }, - { "logical_4", LOGICAL_S4_KEYWORD, OP_NULL, true }, - { "logical_8", LOGICAL_S8_KEYWORD, OP_NULL, true }, - { "real", REAL_KEYWORD, OP_NULL, true }, - { "real_4", REAL_S4_KEYWORD, OP_NULL, true }, - { "real_8", REAL_S8_KEYWORD, OP_NULL, true }, - { "real_16", REAL_S16_KEYWORD, OP_NULL, true }, - { "single", SINGLE, OP_NULL, true }, - { "double", DOUBLE, OP_NULL, true }, - { "precision", PRECISION, OP_NULL, true }, -}; - -/* Implementation of a dynamically expandable buffer for processing input - characters acquired through lexptr and building a value to return in - yylval. Ripped off from ch-exp.y */ - -static char *tempbuf; /* Current buffer contents */ -static int tempbufsize; /* Size of allocated buffer */ -static int tempbufindex; /* Current index into buffer */ - -#define GROWBY_MIN_SIZE 64 /* Minimum amount to grow buffer by */ - -#define CHECKBUF(size) \ - do { \ - if (tempbufindex + (size) >= tempbufsize) \ - { \ - growbuf_by_size (size); \ - } \ - } while (0); - - -/* Grow the static temp buffer if necessary, including allocating the - first one on demand. */ - -static void -growbuf_by_size (int count) -{ - int growby; - - growby = std::max (count, GROWBY_MIN_SIZE); - tempbufsize += growby; - if (tempbuf == NULL) - tempbuf = (char *) malloc (tempbufsize); - else - tempbuf = (char *) realloc (tempbuf, tempbufsize); -} - -/* Blatantly ripped off from ch-exp.y. This routine recognizes F77 - string-literals. - - Recognize a string literal. A string literal is a nonzero sequence - of characters enclosed in matching single quotes, except that - a single character inside single quotes is a character literal, which - we reject as a string literal. To embed the terminator character inside - a string, it is simply doubled (I.E. 'this''is''one''string') */ - -static int -match_string_literal (void) -{ - const char *tokptr = pstate->lexptr; - - for (tempbufindex = 0, tokptr++; *tokptr != '\0'; tokptr++) - { - CHECKBUF (1); - if (*tokptr == *pstate->lexptr) - { - if (*(tokptr + 1) == *pstate->lexptr) - tokptr++; - else - break; - } - tempbuf[tempbufindex++] = *tokptr; - } - if (*tokptr == '\0' /* no terminator */ - || tempbufindex == 0) /* no string */ - return 0; - else - { - tempbuf[tempbufindex] = '\0'; - yylval.sval.ptr = tempbuf; - yylval.sval.length = tempbufindex; - pstate->lexptr = ++tokptr; - return STRING_LITERAL; - } -} - -/* This is set if a NAME token appeared at the very end of the input - string, with no whitespace separating the name from the EOF. This - is used only when parsing to do field name completion. */ -static bool saw_name_at_eof; - -/* This is set if the previously-returned token was a structure - operator '%'. */ -static bool last_was_structop; - -/* Read one token, getting characters through lexptr. */ - -static int -yylex (void) -{ - int c; - int namelen; - unsigned int token; - const char *tokstart; - bool saw_structop = last_was_structop; - - last_was_structop = false; - - retry: - - pstate->prev_lexptr = pstate->lexptr; - - tokstart = pstate->lexptr; - - /* First of all, let us make sure we are not dealing with the - special tokens .true. and .false. which evaluate to 1 and 0. */ - - if (*pstate->lexptr == '.') - { - for (const auto &candidate : boolean_values) - { - if (strncasecmp (tokstart, candidate.name, - strlen (candidate.name)) == 0) - { - pstate->lexptr += strlen (candidate.name); - yylval.lval = candidate.value; - return BOOLEAN_LITERAL; - } - } - } - - /* See if it is a Fortran operator. */ - for (const auto &candidate : fortran_operators) - if (strncasecmp (tokstart, candidate.oper, - strlen (candidate.oper)) == 0) - { - gdb_assert (!candidate.case_sensitive); - pstate->lexptr += strlen (candidate.oper); - yylval.opcode = candidate.opcode; - return candidate.token; - } - - switch (c = *tokstart) - { - case 0: - if (saw_name_at_eof) - { - saw_name_at_eof = false; - return COMPLETE; - } - else if (pstate->parse_completion && saw_structop) - return COMPLETE; - return 0; - - case ' ': - case '\t': - case '\n': - pstate->lexptr++; - goto retry; - - case '\'': - token = match_string_literal (); - if (token != 0) - return (token); - break; - - case '(': - paren_depth++; - pstate->lexptr++; - return c; - - case ')': - if (paren_depth == 0) - return 0; - paren_depth--; - pstate->lexptr++; - return c; - - case ',': - if (pstate->comma_terminates && paren_depth == 0) - return 0; - pstate->lexptr++; - return c; - - case '.': - /* Might be a floating point number. */ - if (pstate->lexptr[1] < '0' || pstate->lexptr[1] > '9') - goto symbol; /* Nope, must be a symbol. */ - [[fallthrough]]; - - case '0': - case '1': - case '2': - case '3': - case '4': - case '5': - case '6': - case '7': - case '8': - case '9': - { - /* It's a number. */ - int got_dot = 0, got_e = 0, got_d = 0, toktype; - const char *p = tokstart; - int hex = input_radix > 10; - - if (c == '0' && (p[1] == 'x' || p[1] == 'X')) - { - p += 2; - hex = 1; - } - else if (c == '0' && (p[1]=='t' || p[1]=='T' - || p[1]=='d' || p[1]=='D')) - { - p += 2; - hex = 0; - } - - for (;; ++p) - { - if (!hex && !got_e && (*p == 'e' || *p == 'E')) - got_dot = got_e = 1; - else if (!hex && !got_d && (*p == 'd' || *p == 'D')) - got_dot = got_d = 1; - else if (!hex && !got_dot && *p == '.') - got_dot = 1; - else if (((got_e && (p[-1] == 'e' || p[-1] == 'E')) - || (got_d && (p[-1] == 'd' || p[-1] == 'D'))) - && (*p == '-' || *p == '+')) - /* This is the sign of the exponent, not the end of the - number. */ - continue; - /* We will take any letters or digits. parse_number will - complain if past the radix, or if L or U are not final. */ - else if ((*p < '0' || *p > '9') - && ((*p < 'a' || *p > 'z') - && (*p < 'A' || *p > 'Z'))) - break; - } - toktype = parse_number (pstate, tokstart, p - tokstart, - got_dot|got_e|got_d, - &yylval); - if (toktype == ERROR) - error (_("Invalid number \"%.*s\"."), (int) (p - tokstart), - tokstart); - pstate->lexptr = p; - return toktype; - } - - case '%': - last_was_structop = true; - [[fallthrough]]; - case '+': - case '-': - case '*': - case '/': - case '|': - case '&': - case '^': - case '~': - case '!': - case '@': - case '<': - case '>': - case '[': - case ']': - case '?': - case ':': - case '=': - case '{': - case '}': - symbol: - pstate->lexptr++; - return c; - } - - if (!(c == '_' || c == '$' || c ==':' - || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'))) - /* We must have come across a bad character (e.g. ';'). */ - error (_("Invalid character '%c' in expression."), c); - - namelen = 0; - for (c = tokstart[namelen]; - (c == '_' || c == '$' || c == ':' || (c >= '0' && c <= '9') - || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')); - c = tokstart[++namelen]); - - /* The token "if" terminates the expression and is NOT - removed from the input stream. */ - - if (namelen == 2 && tokstart[0] == 'i' && tokstart[1] == 'f') - return 0; - - pstate->lexptr += namelen; - - /* Catch specific keywords. */ - - for (const auto &keyword : f_keywords) - if (strlen (keyword.oper) == namelen - && ((!keyword.case_sensitive - && strncasecmp (tokstart, keyword.oper, namelen) == 0) - || (keyword.case_sensitive - && strncmp (tokstart, keyword.oper, namelen) == 0))) - { - yylval.opcode = keyword.opcode; - return keyword.token; - } - - yylval.sval.ptr = tokstart; - yylval.sval.length = namelen; - - if (*tokstart == '$') - return DOLLAR_VARIABLE; - - /* Use token-type TYPENAME for symbols that happen to be defined - currently as names of types; NAME for other symbols. - The caller is not constrained to care about the distinction. */ - { - std::string tmp = copy_name (yylval.sval); - struct block_symbol result; - const domain_search_flags lookup_domains[] = - { - SEARCH_VFT, - SEARCH_STRUCT_DOMAIN, - SEARCH_MODULE_DOMAIN - }; - int hextype; - - for (const auto &domain : lookup_domains) - { - result = lookup_symbol (tmp.c_str (), pstate->expression_context_block, - domain, NULL); - if (result.symbol && result.symbol->loc_class () == LOC_TYPEDEF) - { - yylval.tsym.type = result.symbol->type (); - return TYPENAME; - } - - if (result.symbol) - break; - } - - yylval.tsym.type - = language_lookup_primitive_type (pstate->language (), - pstate->gdbarch (), tmp.c_str ()); - if (yylval.tsym.type != NULL) - return TYPENAME; - - /* This is post the symbol search as symbols can hide intrinsics. Also, - give Fortran intrinsics priority over C symbols. This prevents - non-Fortran symbols from hiding intrinsics, for example abs. */ - if (!result.symbol || result.symbol->language () != language_fortran) - for (const auto &intrinsic : f_intrinsics) - { - gdb_assert (!intrinsic.case_sensitive); - if (strlen (intrinsic.oper) == namelen - && strncasecmp (tokstart, intrinsic.oper, namelen) == 0) - { - yylval.opcode = intrinsic.opcode; - return intrinsic.token; - } - } - - /* Input names that aren't symbols but ARE valid hex numbers, - when the input radix permits them, can be names or numbers - depending on the parse. Note we support radixes > 16 here. */ - if (!result.symbol - && ((tokstart[0] >= 'a' && tokstart[0] < 'a' + input_radix - 10) - || (tokstart[0] >= 'A' && tokstart[0] < 'A' + input_radix - 10))) - { - YYSTYPE newlval; /* Its value is ignored. */ - hextype = parse_number (pstate, tokstart, namelen, 0, &newlval); - if (hextype == INT) - { - yylval.ssym.sym = result; - yylval.ssym.is_a_field_of_this = false; - return NAME_OR_INT; - } - } - - if (pstate->parse_completion && *pstate->lexptr == '\0') - saw_name_at_eof = true; - - /* Any other kind of symbol */ - yylval.ssym.sym = result; - yylval.ssym.is_a_field_of_this = false; - return NAME; - } -} - -int -f_language::parser (struct parser_state *par_state) const -{ - /* Setting up the parser state. */ - scoped_restore pstate_restore = make_scoped_restore (&pstate); - scoped_restore restore_yydebug = make_scoped_restore (&yydebug, - par_state->debug); - gdb_assert (par_state != NULL); - pstate = par_state; - last_was_structop = false; - saw_name_at_eof = false; - paren_depth = 0; - - struct type_stack stack; - scoped_restore restore_type_stack = make_scoped_restore (&type_stack, - &stack); - - int result = yyparse (); - if (!result) - pstate->set_operation (pstate->pop ()); - return result; -} - -static void -yyerror (const char *msg) -{ - pstate->parse_error (msg); -} diff --git a/gdb/f-lang.c b/gdb/f-lang.c index 5a40995f3103..19ea1645970d 100644 --- a/gdb/f-lang.c +++ b/gdb/f-lang.c @@ -28,6 +28,7 @@ #include "varobj.h" #include "gdbcore.h" #include "f-lang.h" +#include "f-exp-parser.h" #include "valprint.h" #include "value.h" #include "cp-support.h" @@ -1632,6 +1633,14 @@ fortran_structop_operation::evaluate (struct type *expect_type, /* See language.h. */ +int +f_language::parser (struct parser_state *ps) const +{ + return f_parse (ps); +} + +/* See language.h. */ + void f_language::print_array_index (struct type *index_type, LONGEST index, struct ui_file *stream, -- 2.55.0