@@ -869,6 +869,7 @@ dump_subexp_body_standard (struct expression *exp,
case UNOP_MIN:
case UNOP_ODD:
case UNOP_TRUNC:
+ case UNOP_KIND:
elt = dump_subexp (exp, stream, elt);
break;
case OP_LONG:
@@ -78,6 +78,10 @@ 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);
+
%}
/* Although the yacc "value" of an expression is not used,
@@ -149,7 +153,7 @@ static int parse_number (struct parser_state *, const char *, int,
%token <ssym> NAME_OR_INT
-%token SIZEOF
+%token SIZEOF KIND
%token ERROR
/* Special type cases, put in to allow the parser to distinguish different
@@ -228,6 +232,10 @@ exp : SIZEOF exp %prec UNARY
{ write_exp_elt_opcode (pstate, UNOP_SIZEOF); }
;
+exp : KIND '(' exp ')' %prec UNARY
+ { write_exp_elt_opcode (pstate, UNOP_KIND); }
+ ;
+
/* No more explicit array operators, we treat everything in F77 as
a function call. The disambiguation as to whether we are
doing a subscript operation or a function call is done
@@ -530,6 +538,13 @@ ptype : typebase
case tp_function:
follow_type = lookup_function_type (follow_type);
break;
+ case tp_kind:
+ {
+ int kind_val = pop_type_int ();
+ follow_type
+ = convert_to_kind_type (follow_type, kind_val);
+ }
+ break;
}
$$ = follow_type;
}
@@ -548,6 +563,8 @@ abs_decl: '*'
direct_abs_decl: '(' abs_decl ')'
{ $$ = $2; }
+ | '(' KIND '=' INT ')'
+ { push_kind_type ($4.val, $4.type); }
| direct_abs_decl func_mod
{ push_type (tp_function); }
| func_mod
@@ -773,6 +790,54 @@ parse_number (struct parser_state *par_state,
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_UNSIGNED (type))
+ {
+ ULONGEST uval = static_cast <ULONGEST> (val);
+ if (uval > INT_MAX)
+ error (_("kind value out of range"));
+ ival = static_cast <int> (uval);
+ }
+ else
+ {
+ if (val > INT_MAX || val < 0)
+ error (_("kind value out of range"));
+ ival = static_cast <int> (val);
+ }
+
+ push_type_int (ival);
+ push_type (tp_kind);
+}
+
+/* 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)
+{
+ 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;
+ }
+
+ error (_("unsupported kind %d for type %s"),
+ kind, TYPE_SAFE_NAME (basetype));
+
+ /* Should never get here. */
+ return nullptr;
+}
+
struct token
{
/* The string to match against. */
@@ -840,6 +905,9 @@ static const struct token f77_keywords[] =
{ "sizeof", SIZEOF, BINOP_END, true },
{ "real_8", REAL_S8_KEYWORD, BINOP_END, true },
{ "real", REAL_KEYWORD, BINOP_END, true },
+ /* The following correspond to actual functions in Fortran and are case
+ insensitive. */
+ { "kind", KIND, BINOP_END, false }
};
/* Implementation of a dynamically expandable buffer for processing input
@@ -243,8 +243,43 @@ struct value *
evaluate_subexp_f (struct type *expect_type, struct expression *exp,
int *pos, enum noside noside)
{
- /* Currently no special handling is required. */
- return evaluate_subexp_standard (expect_type, exp, pos, noside);
+ struct value *arg1 = NULL;
+ enum exp_opcode op;
+ int pc;
+ struct type *type;
+
+ pc = *pos;
+ *pos += 1;
+ op = exp->elts[pc].opcode;
+
+ switch (op)
+ {
+ default:
+ *pos -= 1;
+ return evaluate_subexp_standard (expect_type, exp, pos, noside);
+
+ case UNOP_KIND:
+ arg1 = evaluate_subexp (NULL, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
+ type = value_type (arg1);
+
+ switch (TYPE_CODE (type))
+ {
+ case TYPE_CODE_STRUCT:
+ case TYPE_CODE_UNION:
+ case TYPE_CODE_MODULE:
+ case TYPE_CODE_FUNC:
+ error (_("argument to kind must be an intrinsic type"));
+ }
+
+ if (!TYPE_TARGET_TYPE (type))
+ return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
+ TYPE_LENGTH (type));
+ return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
+ TYPE_LENGTH (TYPE_TARGET_TYPE(type)));
+ }
+
+ /* Should be unreachable. */
+ return nullptr;
}
static const char *f_extensions[] =
@@ -927,6 +927,7 @@ operator_length_standard (const struct expression *expr, int endpos,
case UNOP_CHR:
case UNOP_FLOAT:
case UNOP_HIGH:
+ case UNOP_KIND:
case UNOP_ODD:
case UNOP_ORD:
case UNOP_TRUNC:
@@ -214,7 +214,8 @@ enum type_pieces
tp_const,
tp_volatile,
tp_space_identifier,
- tp_type_stack
+ tp_type_stack,
+ tp_kind
};
/* The stack can contain either an enum type_pieces or an int. */
union type_stack_elt
@@ -244,6 +244,7 @@ OP (UNOP_ORD)
OP (UNOP_ABS)
OP (UNOP_FLOAT)
OP (UNOP_HIGH)
+OP (UNOP_KIND) /* Fortran KIND function. */
OP (UNOP_MAX)
OP (UNOP_MIN)
OP (UNOP_ODD)
new file mode 100644
@@ -0,0 +1,42 @@
+# Copyright 2019 Free Software Foundation, Inc.
+#
+# 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 <http://www.gnu.org/licenses/>.
+
+# This file tests GDB's handling of Fortran builtin intrinsic functions.
+
+load_lib "fortran.exp"
+
+if { [skip_fortran_tests] } { continue }
+
+standard_testfile .f90
+
+if { [prepare_for_testing "failed to prepare" $testfile $srcfile {debug f90}] } {
+ return -1
+}
+
+if { ![runto MAIN__] } {
+ perror "Could not run to breakpoint `MAIN__'."
+ continue
+}
+
+gdb_breakpoint [gdb_get_line_number "stop-here"]
+gdb_continue_to_breakpoint "stop-here" ".*stop-here.*"
+
+# Test KIND
+
+gdb_test "p kind (l1)" " = 1"
+gdb_test "p kind (l2)" " = 2"
+gdb_test "p kind (l4)" " = 4"
+gdb_test "p kind (l8)" " = 8"
+gdb_test "p kind (s1)" "argument to kind must be an intrinsic type"
new file mode 100644
@@ -0,0 +1,39 @@
+! Copyright 2019 Free Software Foundation, Inc.
+!
+! 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 <http://www.gnu.org/licenses/>.
+
+program test
+ logical :: l
+ logical (kind=1) :: l1
+ logical (kind=2) :: l2
+ logical (kind=4) :: l4
+ logical (kind=8) :: l8
+
+ type :: a_struct
+ logical :: a1
+ logical :: a2
+ end type a_struct
+
+ type (a_struct) :: s1
+
+ s1%a1 = .TRUE.
+ s1%a2 = .FALSE.
+
+ l1 = .TRUE.
+ l2 = .TRUE.
+ l4 = .TRUE.
+ l8 = .TRUE.
+
+ l = .FALSE. ! stop-here
+end
new file mode 100644
@@ -0,0 +1,35 @@
+# Copyright 2019 Free Software Foundation, Inc.
+#
+# 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 <http://www.gnu.org/licenses/>.
+
+# This is a set of tests related to GDB's ability to parse and
+# correctly handle the (kind=N) type adjustment mechanism within
+# Fortran.
+
+load_lib "fortran.exp"
+
+if { [skip_fortran_tests] } { continue }
+
+# Test parsing of `(kind=N)` type modifiers.
+proc test_basic_parsing_of_type_kinds {} {
+ gdb_test "p ((character (kind=1)) 1)" " = 1"
+}
+
+clean_restart
+
+if [set_lang_fortran] then {
+ test_basic_parsing_of_type_kinds
+} else {
+ warning "$test_name tests suppressed." 0
+}