2 /* YACC parser for Fortran expressions, for GDB.
3 Copyright (C) 1986-2021 Free Software Foundation, Inc.
5 Contributed by Motorola. Adapted from the C parser by Farooq Butt
6 (fmbutt@engage.sps.mot.com).
8 This file is part of GDB.
10 This program is free software; you can redistribute it and/or modify
11 it under the terms of the GNU General Public License as published by
12 the Free Software Foundation; either version 3 of the License, or
13 (at your option) any later version.
15 This program is distributed in the hope that it will be useful,
16 but WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 GNU General Public License for more details.
20 You should have received a copy of the GNU General Public License
21 along with this program. If not, see <http://www.gnu.org/licenses/>. */
23 /* This was blantantly ripped off the C expression parser, please
24 be aware of that as you look at its basic structure -FMB */
26 /* Parse a F77 expression from text in a string,
27 and return the result as a struct expression pointer.
28 That structure contains arithmetic operations in reverse polish,
29 with constants represented by operations that are followed by special data.
30 See expression.h for the details of the format.
31 What is important here is that it can be built up sequentially
32 during the process of parsing; the lower levels of the tree always
33 come first in the result.
35 Note that malloc's and realloc's in this file are transformed to
36 xmalloc and xrealloc respectively by the same sed command in the
37 makefile that remaps any other malloc/realloc inserted by the parser
38 generator. Doing this with #defines and trying to control the interaction
39 with include files (<malloc.h> and <stdlib.h> for example) just became
40 too messy, particularly when such includes can be inserted at random
41 times by the parser generator. */
46 #include "expression.h"
48 #include "parser-defs.h"
51 #include "bfd.h" /* Required by objfiles.h. */
52 #include "symfile.h" /* Required by objfiles.h. */
53 #include "objfiles.h" /* For have_full_symbols and have_partial_symbols */
57 #include "type-stack.h"
60 #define parse_type(ps) builtin_type (ps->gdbarch ())
61 #define parse_f_type(ps) builtin_f_type (ps->gdbarch ())
63 /* Remap normal yacc parser interface names (yyparse, yylex, yyerror,
65 #define GDB_YY_REMAP_PREFIX f_
68 /* The state of the parser, used internally when we are parsing the
71 static struct parser_state *pstate = NULL;
73 /* Depth of parentheses. */
74 static int paren_depth;
76 /* The current type stack. */
77 static struct type_stack *type_stack;
81 static int yylex (void);
83 static void yyerror (const char *);
85 static void growbuf_by_size (int);
87 static int match_string_literal (void);
89 static void push_kind_type (LONGEST val, struct type *type);
91 static struct type *convert_to_kind_type (struct type *basetype, int kind);
96 /* Although the yacc "value" of an expression is not used,
97 since the result is stored in the structure being created,
98 other node types do have values. */
115 struct symtoken ssym;
117 enum exp_opcode opcode;
118 struct internalvar *ivar;
125 /* YYSTYPE gets defined by %union */
126 static int parse_number (struct parser_state *, const char *, int,
130 %type <voidval> exp type_exp start variable
131 %type <tval> type typebase
132 %type <tvec> nonempty_typelist
133 /* %type <bval> block */
135 /* Fancy type parsing. */
136 %type <voidval> func_mod direct_abs_decl abs_decl
139 %token <typed_val> INT
140 %token <typed_val_float> FLOAT
142 /* Both NAME and TYPENAME tokens represent symbols in the input,
143 and both convey their data as strings.
144 But a TYPENAME is a string that happens to be defined as a typedef
145 or builtin type name (such as int or char)
146 and a NAME is any other symbol.
147 Contexts where this distinction is not important can use the
148 nonterminal "name", which matches either NAME or TYPENAME. */
150 %token <sval> STRING_LITERAL
151 %token <lval> BOOLEAN_LITERAL
153 %token <tsym> TYPENAME
154 %token <voidval> COMPLETE
156 %type <ssym> name_not_typename
158 /* A NAME_OR_INT is a symbol which is not known in the symbol table,
159 but which would parse as a valid number in the current input radix.
160 E.g. "c" when input_radix==16. Depending on the parse, it will be
161 turned into a name or into a number. */
163 %token <ssym> NAME_OR_INT
168 /* Special type cases, put in to allow the parser to distinguish different
170 %token INT_KEYWORD INT_S2_KEYWORD LOGICAL_S1_KEYWORD LOGICAL_S2_KEYWORD
171 %token LOGICAL_S8_KEYWORD
172 %token LOGICAL_KEYWORD REAL_KEYWORD REAL_S8_KEYWORD REAL_S16_KEYWORD
173 %token COMPLEX_KEYWORD
174 %token COMPLEX_S8_KEYWORD COMPLEX_S16_KEYWORD COMPLEX_S32_KEYWORD
175 %token BOOL_AND BOOL_OR BOOL_NOT
176 %token SINGLE DOUBLE PRECISION
177 %token <lval> CHARACTER
179 %token <sval> DOLLAR_VARIABLE
181 %token <opcode> ASSIGN_MODIFY
182 %token <opcode> UNOP_INTRINSIC BINOP_INTRINSIC
183 %token <opcode> UNOP_OR_BINOP_INTRINSIC
187 %right '=' ASSIGN_MODIFY
196 %left LESSTHAN GREATERTHAN LEQ GEQ
214 { pstate->push_new<type_operation> ($1); }
221 /* Expressions, not including the comma operator. */
222 exp : '*' exp %prec UNARY
223 { pstate->wrap<unop_ind_operation> (); }
226 exp : '&' exp %prec UNARY
227 { pstate->wrap<unop_addr_operation> (); }
230 exp : '-' exp %prec UNARY
231 { pstate->wrap<unary_neg_operation> (); }
234 exp : BOOL_NOT exp %prec UNARY
235 { pstate->wrap<unary_logical_not_operation> (); }
238 exp : '~' exp %prec UNARY
239 { pstate->wrap<unary_complement_operation> (); }
242 exp : SIZEOF exp %prec UNARY
243 { pstate->wrap<unop_sizeof_operation> (); }
246 exp : KIND '(' exp ')' %prec UNARY
247 { pstate->wrap<fortran_kind_operation> (); }
250 exp : UNOP_OR_BINOP_INTRINSIC '('
251 { pstate->start_arglist (); }
254 int n = pstate->end_arglist ();
255 gdb_assert (n == 1 || n == 2);
256 if ($1 == FORTRAN_ASSOCIATED)
259 pstate->wrap<fortran_associated_1arg> ();
261 pstate->wrap2<fortran_associated_2arg> ();
265 std::vector<operation_up> args
266 = pstate->pop_vector (n);
267 gdb_assert ($1 == FORTRAN_LBOUND
268 || $1 == FORTRAN_UBOUND);
272 (new fortran_bound_1arg ($1,
273 std::move (args[0])));
276 (new fortran_bound_2arg ($1,
278 std::move (args[1])));
279 pstate->push (std::move (op));
286 { pstate->arglist_len = 1; }
288 { pstate->arglist_len = 2; }
291 /* No more explicit array operators, we treat everything in F77 as
292 a function call. The disambiguation as to whether we are
293 doing a subscript operation or a function call is done
297 { pstate->start_arglist (); }
300 std::vector<operation_up> args
301 = pstate->pop_vector (pstate->end_arglist ());
302 pstate->push_new<fortran_undetermined>
303 (pstate->pop (), std::move (args));
307 exp : UNOP_INTRINSIC '(' exp ')'
312 pstate->wrap<fortran_abs_operation> ();
314 case UNOP_FORTRAN_FLOOR:
315 pstate->wrap<fortran_floor_operation> ();
317 case UNOP_FORTRAN_CEILING:
318 pstate->wrap<fortran_ceil_operation> ();
320 case UNOP_FORTRAN_ALLOCATED:
321 pstate->wrap<fortran_allocated_operation> ();
323 case UNOP_FORTRAN_RANK:
324 pstate->wrap<fortran_rank_operation> ();
327 gdb_assert_not_reached ("unhandled intrinsic");
332 exp : BINOP_INTRINSIC '(' exp ',' exp ')'
337 pstate->wrap2<fortran_mod_operation> ();
339 case BINOP_FORTRAN_MODULO:
340 pstate->wrap2<fortran_modulo_operation> ();
342 case BINOP_FORTRAN_CMPLX:
343 pstate->wrap2<fortran_cmplx_operation> ();
346 gdb_assert_not_reached ("unhandled intrinsic");
355 { pstate->arglist_len = 1; }
359 { pstate->arglist_len = 1; }
362 arglist : arglist ',' exp %prec ABOVE_COMMA
363 { pstate->arglist_len++; }
366 arglist : arglist ',' subrange %prec ABOVE_COMMA
367 { pstate->arglist_len++; }
370 /* There are four sorts of subrange types in F90. */
372 subrange: exp ':' exp %prec ABOVE_COMMA
374 operation_up high = pstate->pop ();
375 operation_up low = pstate->pop ();
376 pstate->push_new<fortran_range_operation>
377 (RANGE_STANDARD, std::move (low),
378 std::move (high), operation_up ());
382 subrange: exp ':' %prec ABOVE_COMMA
384 operation_up low = pstate->pop ();
385 pstate->push_new<fortran_range_operation>
386 (RANGE_HIGH_BOUND_DEFAULT, std::move (low),
387 operation_up (), operation_up ());
391 subrange: ':' exp %prec ABOVE_COMMA
393 operation_up high = pstate->pop ();
394 pstate->push_new<fortran_range_operation>
395 (RANGE_LOW_BOUND_DEFAULT, operation_up (),
396 std::move (high), operation_up ());
400 subrange: ':' %prec ABOVE_COMMA
402 pstate->push_new<fortran_range_operation>
403 (RANGE_LOW_BOUND_DEFAULT
404 | RANGE_HIGH_BOUND_DEFAULT,
405 operation_up (), operation_up (),
410 /* And each of the four subrange types can also have a stride. */
411 subrange: exp ':' exp ':' exp %prec ABOVE_COMMA
413 operation_up stride = pstate->pop ();
414 operation_up high = pstate->pop ();
415 operation_up low = pstate->pop ();
416 pstate->push_new<fortran_range_operation>
417 (RANGE_STANDARD | RANGE_HAS_STRIDE,
418 std::move (low), std::move (high),
423 subrange: exp ':' ':' exp %prec ABOVE_COMMA
425 operation_up stride = pstate->pop ();
426 operation_up low = pstate->pop ();
427 pstate->push_new<fortran_range_operation>
428 (RANGE_HIGH_BOUND_DEFAULT
430 std::move (low), operation_up (),
435 subrange: ':' exp ':' exp %prec ABOVE_COMMA
437 operation_up stride = pstate->pop ();
438 operation_up high = pstate->pop ();
439 pstate->push_new<fortran_range_operation>
440 (RANGE_LOW_BOUND_DEFAULT
442 operation_up (), std::move (high),
447 subrange: ':' ':' exp %prec ABOVE_COMMA
449 operation_up stride = pstate->pop ();
450 pstate->push_new<fortran_range_operation>
451 (RANGE_LOW_BOUND_DEFAULT
452 | RANGE_HIGH_BOUND_DEFAULT
454 operation_up (), operation_up (),
459 complexnum: exp ',' exp
463 exp : '(' complexnum ')'
465 operation_up rhs = pstate->pop ();
466 operation_up lhs = pstate->pop ();
467 pstate->push_new<complex_operation>
468 (std::move (lhs), std::move (rhs),
469 parse_f_type (pstate)->builtin_complex_s16);
473 exp : '(' type ')' exp %prec UNARY
475 pstate->push_new<unop_cast_operation>
476 (pstate->pop (), $2);
482 pstate->push_new<structop_operation>
483 (pstate->pop (), copy_name ($3));
487 exp : exp '%' name COMPLETE
489 structop_base_operation *op
490 = new structop_operation (pstate->pop (),
492 pstate->mark_struct_expression (op);
493 pstate->push (operation_up (op));
497 exp : exp '%' COMPLETE
499 structop_base_operation *op
500 = new structop_operation (pstate->pop (), "");
501 pstate->mark_struct_expression (op);
502 pstate->push (operation_up (op));
506 /* Binary operators in order of decreasing precedence. */
509 { pstate->wrap2<repeat_operation> (); }
512 exp : exp STARSTAR exp
513 { pstate->wrap2<exp_operation> (); }
517 { pstate->wrap2<mul_operation> (); }
521 { pstate->wrap2<div_operation> (); }
525 { pstate->wrap2<add_operation> (); }
529 { pstate->wrap2<sub_operation> (); }
533 { pstate->wrap2<lsh_operation> (); }
537 { pstate->wrap2<rsh_operation> (); }
541 { pstate->wrap2<equal_operation> (); }
544 exp : exp NOTEQUAL exp
545 { pstate->wrap2<notequal_operation> (); }
549 { pstate->wrap2<leq_operation> (); }
553 { pstate->wrap2<geq_operation> (); }
556 exp : exp LESSTHAN exp
557 { pstate->wrap2<less_operation> (); }
560 exp : exp GREATERTHAN exp
561 { pstate->wrap2<gtr_operation> (); }
565 { pstate->wrap2<bitwise_and_operation> (); }
569 { pstate->wrap2<bitwise_xor_operation> (); }
573 { pstate->wrap2<bitwise_ior_operation> (); }
576 exp : exp BOOL_AND exp
577 { pstate->wrap2<logical_and_operation> (); }
581 exp : exp BOOL_OR exp
582 { pstate->wrap2<logical_or_operation> (); }
586 { pstate->wrap2<assign_operation> (); }
589 exp : exp ASSIGN_MODIFY exp
591 operation_up rhs = pstate->pop ();
592 operation_up lhs = pstate->pop ();
593 pstate->push_new<assign_modify_operation>
594 ($2, std::move (lhs), std::move (rhs));
600 pstate->push_new<long_const_operation>
607 parse_number (pstate, $1.stoken.ptr,
608 $1.stoken.length, 0, &val);
609 pstate->push_new<long_const_operation>
618 std::copy (std::begin ($1.val), std::end ($1.val),
620 pstate->push_new<float_const_operation> ($1.type, data);
627 exp : DOLLAR_VARIABLE
628 { pstate->push_dollar ($1); }
631 exp : SIZEOF '(' type ')' %prec UNARY
633 $3 = check_typedef ($3);
634 pstate->push_new<long_const_operation>
635 (parse_f_type (pstate)->builtin_integer,
640 exp : BOOLEAN_LITERAL
641 { pstate->push_new<bool_operation> ($1); }
646 pstate->push_new<string_operation>
651 variable: name_not_typename
652 { struct block_symbol sym = $1.sym;
653 std::string name = copy_name ($1.stoken);
654 pstate->push_symbol (name.c_str (), sym);
665 /* This is where the interesting stuff happens. */
668 struct type *follow_type = $1;
669 struct type *range_type;
672 switch (type_stack->pop ())
678 follow_type = lookup_pointer_type (follow_type);
681 follow_type = lookup_lvalue_reference_type (follow_type);
684 array_size = type_stack->pop_int ();
685 if (array_size != -1)
688 create_static_range_type ((struct type *) NULL,
689 parse_f_type (pstate)
693 create_array_type ((struct type *) NULL,
694 follow_type, range_type);
697 follow_type = lookup_pointer_type (follow_type);
700 follow_type = lookup_function_type (follow_type);
704 int kind_val = type_stack->pop_int ();
706 = convert_to_kind_type (follow_type, kind_val);
715 { type_stack->push (tp_pointer); $$ = 0; }
717 { type_stack->push (tp_pointer); $$ = $2; }
719 { type_stack->push (tp_reference); $$ = 0; }
721 { type_stack->push (tp_reference); $$ = $2; }
725 direct_abs_decl: '(' abs_decl ')'
727 | '(' KIND '=' INT ')'
728 { push_kind_type ($4.val, $4.type); }
730 { push_kind_type ($2.val, $2.type); }
731 | direct_abs_decl func_mod
732 { type_stack->push (tp_function); }
734 { type_stack->push (tp_function); }
739 | '(' nonempty_typelist ')'
740 { free ($2); $$ = 0; }
743 typebase /* Implements (approximately): (type-qualifier)* type-specifier */
747 { $$ = parse_f_type (pstate)->builtin_integer; }
749 { $$ = parse_f_type (pstate)->builtin_integer_s2; }
751 { $$ = parse_f_type (pstate)->builtin_character; }
753 { $$ = parse_f_type (pstate)->builtin_logical_s8; }
755 { $$ = parse_f_type (pstate)->builtin_logical; }
757 { $$ = parse_f_type (pstate)->builtin_logical_s2; }
759 { $$ = parse_f_type (pstate)->builtin_logical_s1; }
761 { $$ = parse_f_type (pstate)->builtin_real; }
763 { $$ = parse_f_type (pstate)->builtin_real_s8; }
765 { $$ = parse_f_type (pstate)->builtin_real_s16; }
767 { $$ = parse_f_type (pstate)->builtin_complex_s8; }
769 { $$ = parse_f_type (pstate)->builtin_complex_s8; }
770 | COMPLEX_S16_KEYWORD
771 { $$ = parse_f_type (pstate)->builtin_complex_s16; }
772 | COMPLEX_S32_KEYWORD
773 { $$ = parse_f_type (pstate)->builtin_complex_s32; }
775 { $$ = parse_f_type (pstate)->builtin_real;}
777 { $$ = parse_f_type (pstate)->builtin_real_s8;}
778 | SINGLE COMPLEX_KEYWORD
779 { $$ = parse_f_type (pstate)->builtin_complex_s8;}
780 | DOUBLE COMPLEX_KEYWORD
781 { $$ = parse_f_type (pstate)->builtin_complex_s16;}
786 { $$ = (struct type **) malloc (sizeof (struct type *) * 2);
787 $<ivec>$[0] = 1; /* Number of types in vector */
790 | nonempty_typelist ',' type
791 { int len = sizeof (struct type *) * (++($<ivec>1[0]) + 1);
792 $$ = (struct type **) realloc ((char *) $1, len);
793 $$[$<ivec>$[0]] = $3;
801 name_not_typename : NAME
802 /* These would be useful if name_not_typename was useful, but it is just
803 a fake for "variable", so these cause reduce/reduce conflicts because
804 the parser can't tell whether NAME_OR_INT is a name_not_typename (=variable,
805 =exp) or just an exp. If name_not_typename was ever used in an lvalue
806 context where only a name could occur, this might be useful.
813 /* Take care of parsing a number (anything that starts with a digit).
814 Set yylval and return the token type; update lexptr.
815 LEN is the number of characters in it. */
817 /*** Needs some error checking for the float case ***/
820 parse_number (struct parser_state *par_state,
821 const char *p, int len, int parsed_float, YYSTYPE *putithere)
826 int base = input_radix;
830 struct type *signed_type;
831 struct type *unsigned_type;
835 /* It's a float since it contains a point or an exponent. */
836 /* [dD] is not understood as an exponent by parse_float,
841 for (tmp2 = tmp; *tmp2; ++tmp2)
842 if (*tmp2 == 'd' || *tmp2 == 'D')
845 /* FIXME: Should this use different types? */
846 putithere->typed_val_float.type = parse_f_type (pstate)->builtin_real_s8;
847 bool parsed = parse_float (tmp, len,
848 putithere->typed_val_float.type,
849 putithere->typed_val_float.val);
851 return parsed? FLOAT : ERROR;
854 /* Handle base-switching prefixes 0x, 0t, 0d, 0 */
890 if (len == 0 && c == 'l')
892 else if (len == 0 && c == 'u')
897 if (c >= '0' && c <= '9')
899 else if (c >= 'a' && c <= 'f')
902 return ERROR; /* Char not a digit */
904 return ERROR; /* Invalid digit in this base */
908 /* Portably test for overflow (only works for nonzero values, so make
909 a second check for zero). */
910 if ((prevn >= n) && n != 0)
911 unsigned_p=1; /* Try something unsigned */
912 /* If range checking enabled, portably test for unsigned overflow. */
913 if (RANGE_CHECK && n != 0)
915 if ((unsigned_p && (unsigned)prevn >= (unsigned)n))
916 range_error (_("Overflow on numeric constant."));
921 /* If the number is too big to be an int, or it's got an l suffix
922 then it's a long. Work out if this has to be a long by
923 shifting right and seeing if anything remains, and the
924 target int size is different to the target long size.
926 In the expression below, we could have tested
927 (n >> gdbarch_int_bit (parse_gdbarch))
928 to see if it was zero,
929 but too many compilers warn about that, when ints and longs
930 are the same size. So we shift it twice, with fewer bits
931 each time, for the same result. */
933 if ((gdbarch_int_bit (par_state->gdbarch ())
934 != gdbarch_long_bit (par_state->gdbarch ())
936 >> (gdbarch_int_bit (par_state->gdbarch ())-2))) /* Avoid
940 high_bit = ((ULONGEST)1)
941 << (gdbarch_long_bit (par_state->gdbarch ())-1);
942 unsigned_type = parse_type (par_state)->builtin_unsigned_long;
943 signed_type = parse_type (par_state)->builtin_long;
948 ((ULONGEST)1) << (gdbarch_int_bit (par_state->gdbarch ()) - 1);
949 unsigned_type = parse_type (par_state)->builtin_unsigned_int;
950 signed_type = parse_type (par_state)->builtin_int;
953 putithere->typed_val.val = n;
955 /* If the high bit of the worked out type is set then this number
956 has to be unsigned. */
958 if (unsigned_p || (n & high_bit))
959 putithere->typed_val.type = unsigned_type;
961 putithere->typed_val.type = signed_type;
966 /* Called to setup the type stack when we encounter a '(kind=N)' type
967 modifier, performs some bounds checking on 'N' and then pushes this to
968 the type stack followed by the 'tp_kind' marker. */
970 push_kind_type (LONGEST val, struct type *type)
974 if (type->is_unsigned ())
976 ULONGEST uval = static_cast <ULONGEST> (val);
978 error (_("kind value out of range"));
979 ival = static_cast <int> (uval);
983 if (val > INT_MAX || val < 0)
984 error (_("kind value out of range"));
985 ival = static_cast <int> (val);
988 type_stack->push (ival);
989 type_stack->push (tp_kind);
992 /* Called when a type has a '(kind=N)' modifier after it, for example
993 'character(kind=1)'. The BASETYPE is the type described by 'character'
994 in our example, and KIND is the integer '1'. This function returns a
995 new type that represents the basetype of a specific kind. */
997 convert_to_kind_type (struct type *basetype, int kind)
999 if (basetype == parse_f_type (pstate)->builtin_character)
1001 /* Character of kind 1 is a special case, this is the same as the
1002 base character type. */
1004 return parse_f_type (pstate)->builtin_character;
1006 else if (basetype == parse_f_type (pstate)->builtin_complex_s8)
1009 return parse_f_type (pstate)->builtin_complex_s8;
1011 return parse_f_type (pstate)->builtin_complex_s16;
1012 else if (kind == 16)
1013 return parse_f_type (pstate)->builtin_complex_s32;
1015 else if (basetype == parse_f_type (pstate)->builtin_real)
1018 return parse_f_type (pstate)->builtin_real;
1020 return parse_f_type (pstate)->builtin_real_s8;
1021 else if (kind == 16)
1022 return parse_f_type (pstate)->builtin_real_s16;
1024 else if (basetype == parse_f_type (pstate)->builtin_logical)
1027 return parse_f_type (pstate)->builtin_logical_s1;
1029 return parse_f_type (pstate)->builtin_logical_s2;
1031 return parse_f_type (pstate)->builtin_logical;
1033 return parse_f_type (pstate)->builtin_logical_s8;
1035 else if (basetype == parse_f_type (pstate)->builtin_integer)
1038 return parse_f_type (pstate)->builtin_integer_s2;
1040 return parse_f_type (pstate)->builtin_integer;
1042 return parse_f_type (pstate)->builtin_integer_s8;
1045 error (_("unsupported kind %d for type %s"),
1046 kind, TYPE_SAFE_NAME (basetype));
1048 /* Should never get here. */
1054 /* The string to match against. */
1057 /* The lexer token to return. */
1060 /* The expression opcode to embed within the token. */
1061 enum exp_opcode opcode;
1063 /* When this is true the string in OPER is matched exactly including
1064 case, when this is false OPER is matched case insensitively. */
1065 bool case_sensitive;
1068 /* List of Fortran operators. */
1070 static const struct token fortran_operators[] =
1072 { ".and.", BOOL_AND, OP_NULL, false },
1073 { ".or.", BOOL_OR, OP_NULL, false },
1074 { ".not.", BOOL_NOT, OP_NULL, false },
1075 { ".eq.", EQUAL, OP_NULL, false },
1076 { ".eqv.", EQUAL, OP_NULL, false },
1077 { ".neqv.", NOTEQUAL, OP_NULL, false },
1078 { ".xor.", NOTEQUAL, OP_NULL, false },
1079 { "==", EQUAL, OP_NULL, false },
1080 { ".ne.", NOTEQUAL, OP_NULL, false },
1081 { "/=", NOTEQUAL, OP_NULL, false },
1082 { ".le.", LEQ, OP_NULL, false },
1083 { "<=", LEQ, OP_NULL, false },
1084 { ".ge.", GEQ, OP_NULL, false },
1085 { ">=", GEQ, OP_NULL, false },
1086 { ".gt.", GREATERTHAN, OP_NULL, false },
1087 { ">", GREATERTHAN, OP_NULL, false },
1088 { ".lt.", LESSTHAN, OP_NULL, false },
1089 { "<", LESSTHAN, OP_NULL, false },
1090 { "**", STARSTAR, BINOP_EXP, false },
1093 /* Holds the Fortran representation of a boolean, and the integer value we
1094 substitute in when one of the matching strings is parsed. */
1095 struct f77_boolean_val
1097 /* The string representing a Fortran boolean. */
1100 /* The integer value to replace it with. */
1104 /* The set of Fortran booleans. These are matched case insensitively. */
1105 static const struct f77_boolean_val boolean_values[] =
1111 static const struct token f77_keywords[] =
1113 /* Historically these have always been lowercase only in GDB. */
1114 { "complex_16", COMPLEX_S16_KEYWORD, OP_NULL, true },
1115 { "complex_32", COMPLEX_S32_KEYWORD, OP_NULL, true },
1116 { "character", CHARACTER, OP_NULL, true },
1117 { "integer_2", INT_S2_KEYWORD, OP_NULL, true },
1118 { "logical_1", LOGICAL_S1_KEYWORD, OP_NULL, true },
1119 { "logical_2", LOGICAL_S2_KEYWORD, OP_NULL, true },
1120 { "logical_8", LOGICAL_S8_KEYWORD, OP_NULL, true },
1121 { "complex_8", COMPLEX_S8_KEYWORD, OP_NULL, true },
1122 { "integer", INT_KEYWORD, OP_NULL, true },
1123 { "logical", LOGICAL_KEYWORD, OP_NULL, true },
1124 { "real_16", REAL_S16_KEYWORD, OP_NULL, true },
1125 { "complex", COMPLEX_KEYWORD, OP_NULL, true },
1126 { "sizeof", SIZEOF, OP_NULL, true },
1127 { "real_8", REAL_S8_KEYWORD, OP_NULL, true },
1128 { "real", REAL_KEYWORD, OP_NULL, true },
1129 { "single", SINGLE, OP_NULL, true },
1130 { "double", DOUBLE, OP_NULL, true },
1131 { "precision", PRECISION, OP_NULL, true },
1132 /* The following correspond to actual functions in Fortran and are case
1134 { "kind", KIND, OP_NULL, false },
1135 { "abs", UNOP_INTRINSIC, UNOP_ABS, false },
1136 { "mod", BINOP_INTRINSIC, BINOP_MOD, false },
1137 { "floor", UNOP_INTRINSIC, UNOP_FORTRAN_FLOOR, false },
1138 { "ceiling", UNOP_INTRINSIC, UNOP_FORTRAN_CEILING, false },
1139 { "modulo", BINOP_INTRINSIC, BINOP_FORTRAN_MODULO, false },
1140 { "cmplx", BINOP_INTRINSIC, BINOP_FORTRAN_CMPLX, false },
1141 { "lbound", UNOP_OR_BINOP_INTRINSIC, FORTRAN_LBOUND, false },
1142 { "ubound", UNOP_OR_BINOP_INTRINSIC, FORTRAN_UBOUND, false },
1143 { "allocated", UNOP_INTRINSIC, UNOP_FORTRAN_ALLOCATED, false },
1144 { "associated", UNOP_OR_BINOP_INTRINSIC, FORTRAN_ASSOCIATED, false },
1145 { "rank", UNOP_INTRINSIC, UNOP_FORTRAN_RANK, false },
1148 /* Implementation of a dynamically expandable buffer for processing input
1149 characters acquired through lexptr and building a value to return in
1150 yylval. Ripped off from ch-exp.y */
1152 static char *tempbuf; /* Current buffer contents */
1153 static int tempbufsize; /* Size of allocated buffer */
1154 static int tempbufindex; /* Current index into buffer */
1156 #define GROWBY_MIN_SIZE 64 /* Minimum amount to grow buffer by */
1158 #define CHECKBUF(size) \
1160 if (tempbufindex + (size) >= tempbufsize) \
1162 growbuf_by_size (size); \
1167 /* Grow the static temp buffer if necessary, including allocating the
1168 first one on demand. */
1171 growbuf_by_size (int count)
1175 growby = std::max (count, GROWBY_MIN_SIZE);
1176 tempbufsize += growby;
1177 if (tempbuf == NULL)
1178 tempbuf = (char *) malloc (tempbufsize);
1180 tempbuf = (char *) realloc (tempbuf, tempbufsize);
1183 /* Blatantly ripped off from ch-exp.y. This routine recognizes F77
1186 Recognize a string literal. A string literal is a nonzero sequence
1187 of characters enclosed in matching single quotes, except that
1188 a single character inside single quotes is a character literal, which
1189 we reject as a string literal. To embed the terminator character inside
1190 a string, it is simply doubled (I.E. 'this''is''one''string') */
1193 match_string_literal (void)
1195 const char *tokptr = pstate->lexptr;
1197 for (tempbufindex = 0, tokptr++; *tokptr != '\0'; tokptr++)
1200 if (*tokptr == *pstate->lexptr)
1202 if (*(tokptr + 1) == *pstate->lexptr)
1207 tempbuf[tempbufindex++] = *tokptr;
1209 if (*tokptr == '\0' /* no terminator */
1210 || tempbufindex == 0) /* no string */
1214 tempbuf[tempbufindex] = '\0';
1215 yylval.sval.ptr = tempbuf;
1216 yylval.sval.length = tempbufindex;
1217 pstate->lexptr = ++tokptr;
1218 return STRING_LITERAL;
1222 /* This is set if a NAME token appeared at the very end of the input
1223 string, with no whitespace separating the name from the EOF. This
1224 is used only when parsing to do field name completion. */
1225 static bool saw_name_at_eof;
1227 /* This is set if the previously-returned token was a structure
1229 static bool last_was_structop;
1231 /* Read one token, getting characters through lexptr. */
1239 const char *tokstart;
1240 bool saw_structop = last_was_structop;
1242 last_was_structop = false;
1246 pstate->prev_lexptr = pstate->lexptr;
1248 tokstart = pstate->lexptr;
1250 /* First of all, let us make sure we are not dealing with the
1251 special tokens .true. and .false. which evaluate to 1 and 0. */
1253 if (*pstate->lexptr == '.')
1255 for (int i = 0; i < ARRAY_SIZE (boolean_values); i++)
1257 if (strncasecmp (tokstart, boolean_values[i].name,
1258 strlen (boolean_values[i].name)) == 0)
1260 pstate->lexptr += strlen (boolean_values[i].name);
1261 yylval.lval = boolean_values[i].value;
1262 return BOOLEAN_LITERAL;
1267 /* See if it is a Fortran operator. */
1268 for (int i = 0; i < ARRAY_SIZE (fortran_operators); i++)
1269 if (strncasecmp (tokstart, fortran_operators[i].oper,
1270 strlen (fortran_operators[i].oper)) == 0)
1272 gdb_assert (!fortran_operators[i].case_sensitive);
1273 pstate->lexptr += strlen (fortran_operators[i].oper);
1274 yylval.opcode = fortran_operators[i].opcode;
1275 return fortran_operators[i].token;
1278 switch (c = *tokstart)
1281 if (saw_name_at_eof)
1283 saw_name_at_eof = false;
1286 else if (pstate->parse_completion && saw_structop)
1297 token = match_string_literal ();
1308 if (paren_depth == 0)
1315 if (pstate->comma_terminates && paren_depth == 0)
1321 /* Might be a floating point number. */
1322 if (pstate->lexptr[1] < '0' || pstate->lexptr[1] > '9')
1323 goto symbol; /* Nope, must be a symbol. */
1337 /* It's a number. */
1338 int got_dot = 0, got_e = 0, got_d = 0, toktype;
1339 const char *p = tokstart;
1340 int hex = input_radix > 10;
1342 if (c == '0' && (p[1] == 'x' || p[1] == 'X'))
1347 else if (c == '0' && (p[1]=='t' || p[1]=='T'
1348 || p[1]=='d' || p[1]=='D'))
1356 if (!hex && !got_e && (*p == 'e' || *p == 'E'))
1357 got_dot = got_e = 1;
1358 else if (!hex && !got_d && (*p == 'd' || *p == 'D'))
1359 got_dot = got_d = 1;
1360 else if (!hex && !got_dot && *p == '.')
1362 else if (((got_e && (p[-1] == 'e' || p[-1] == 'E'))
1363 || (got_d && (p[-1] == 'd' || p[-1] == 'D')))
1364 && (*p == '-' || *p == '+'))
1365 /* This is the sign of the exponent, not the end of the
1368 /* We will take any letters or digits. parse_number will
1369 complain if past the radix, or if L or U are not final. */
1370 else if ((*p < '0' || *p > '9')
1371 && ((*p < 'a' || *p > 'z')
1372 && (*p < 'A' || *p > 'Z')))
1375 toktype = parse_number (pstate, tokstart, p - tokstart,
1376 got_dot|got_e|got_d,
1378 if (toktype == ERROR)
1380 char *err_copy = (char *) alloca (p - tokstart + 1);
1382 memcpy (err_copy, tokstart, p - tokstart);
1383 err_copy[p - tokstart] = 0;
1384 error (_("Invalid number \"%s\"."), err_copy);
1391 last_was_structop = true;
1417 if (!(c == '_' || c == '$' || c ==':'
1418 || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')))
1419 /* We must have come across a bad character (e.g. ';'). */
1420 error (_("Invalid character '%c' in expression."), c);
1423 for (c = tokstart[namelen];
1424 (c == '_' || c == '$' || c == ':' || (c >= '0' && c <= '9')
1425 || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'));
1426 c = tokstart[++namelen]);
1428 /* The token "if" terminates the expression and is NOT
1429 removed from the input stream. */
1431 if (namelen == 2 && tokstart[0] == 'i' && tokstart[1] == 'f')
1434 pstate->lexptr += namelen;
1436 /* Catch specific keywords. */
1438 for (int i = 0; i < ARRAY_SIZE (f77_keywords); i++)
1439 if (strlen (f77_keywords[i].oper) == namelen
1440 && ((!f77_keywords[i].case_sensitive
1441 && strncasecmp (tokstart, f77_keywords[i].oper, namelen) == 0)
1442 || (f77_keywords[i].case_sensitive
1443 && strncmp (tokstart, f77_keywords[i].oper, namelen) == 0)))
1445 yylval.opcode = f77_keywords[i].opcode;
1446 return f77_keywords[i].token;
1449 yylval.sval.ptr = tokstart;
1450 yylval.sval.length = namelen;
1452 if (*tokstart == '$')
1453 return DOLLAR_VARIABLE;
1455 /* Use token-type TYPENAME for symbols that happen to be defined
1456 currently as names of types; NAME for other symbols.
1457 The caller is not constrained to care about the distinction. */
1459 std::string tmp = copy_name (yylval.sval);
1460 struct block_symbol result;
1461 enum domain_enum_tag lookup_domains[] =
1469 for (int i = 0; i < ARRAY_SIZE (lookup_domains); ++i)
1471 result = lookup_symbol (tmp.c_str (), pstate->expression_context_block,
1472 lookup_domains[i], NULL);
1473 if (result.symbol && SYMBOL_CLASS (result.symbol) == LOC_TYPEDEF)
1475 yylval.tsym.type = SYMBOL_TYPE (result.symbol);
1484 = language_lookup_primitive_type (pstate->language (),
1485 pstate->gdbarch (), tmp.c_str ());
1486 if (yylval.tsym.type != NULL)
1489 /* Input names that aren't symbols but ARE valid hex numbers,
1490 when the input radix permits them, can be names or numbers
1491 depending on the parse. Note we support radixes > 16 here. */
1493 && ((tokstart[0] >= 'a' && tokstart[0] < 'a' + input_radix - 10)
1494 || (tokstart[0] >= 'A' && tokstart[0] < 'A' + input_radix - 10)))
1496 YYSTYPE newlval; /* Its value is ignored. */
1497 hextype = parse_number (pstate, tokstart, namelen, 0, &newlval);
1500 yylval.ssym.sym = result;
1501 yylval.ssym.is_a_field_of_this = false;
1506 if (pstate->parse_completion && *pstate->lexptr == '\0')
1507 saw_name_at_eof = true;
1509 /* Any other kind of symbol */
1510 yylval.ssym.sym = result;
1511 yylval.ssym.is_a_field_of_this = false;
1517 f_language::parser (struct parser_state *par_state) const
1519 /* Setting up the parser state. */
1520 scoped_restore pstate_restore = make_scoped_restore (&pstate);
1521 scoped_restore restore_yydebug = make_scoped_restore (&yydebug,
1523 gdb_assert (par_state != NULL);
1525 last_was_structop = false;
1526 saw_name_at_eof = false;
1529 struct type_stack stack;
1530 scoped_restore restore_type_stack = make_scoped_restore (&type_stack,
1533 int result = yyparse ();
1535 pstate->set_operation (pstate->pop ());
1540 yyerror (const char *msg)
1542 if (pstate->prev_lexptr)
1543 pstate->lexptr = pstate->prev_lexptr;
1545 error (_("A %s in expression, near `%s'."), msg, pstate->lexptr);