2 /* YACC parser for Fortran expressions, for GDB.
3 Copyright (C) 1986-2022 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> ();
263 else if ($1 == FORTRAN_ARRAY_SIZE)
266 pstate->wrap<fortran_array_size_1arg> ();
268 pstate->wrap2<fortran_array_size_2arg> ();
272 std::vector<operation_up> args
273 = pstate->pop_vector (n);
274 gdb_assert ($1 == FORTRAN_LBOUND
275 || $1 == FORTRAN_UBOUND);
279 (new fortran_bound_1arg ($1,
280 std::move (args[0])));
283 (new fortran_bound_2arg ($1,
285 std::move (args[1])));
286 pstate->push (std::move (op));
293 { pstate->arglist_len = 1; }
295 { pstate->arglist_len = 2; }
298 /* No more explicit array operators, we treat everything in F77 as
299 a function call. The disambiguation as to whether we are
300 doing a subscript operation or a function call is done
304 { pstate->start_arglist (); }
307 std::vector<operation_up> args
308 = pstate->pop_vector (pstate->end_arglist ());
309 pstate->push_new<fortran_undetermined>
310 (pstate->pop (), std::move (args));
314 exp : UNOP_INTRINSIC '(' exp ')'
319 pstate->wrap<fortran_abs_operation> ();
321 case UNOP_FORTRAN_FLOOR:
322 pstate->wrap<fortran_floor_operation> ();
324 case UNOP_FORTRAN_CEILING:
325 pstate->wrap<fortran_ceil_operation> ();
327 case UNOP_FORTRAN_ALLOCATED:
328 pstate->wrap<fortran_allocated_operation> ();
330 case UNOP_FORTRAN_RANK:
331 pstate->wrap<fortran_rank_operation> ();
333 case UNOP_FORTRAN_SHAPE:
334 pstate->wrap<fortran_array_shape_operation> ();
336 case UNOP_FORTRAN_LOC:
337 pstate->wrap<fortran_loc_operation> ();
340 gdb_assert_not_reached ("unhandled intrinsic");
345 exp : BINOP_INTRINSIC '(' exp ',' exp ')'
350 pstate->wrap2<fortran_mod_operation> ();
352 case BINOP_FORTRAN_MODULO:
353 pstate->wrap2<fortran_modulo_operation> ();
355 case BINOP_FORTRAN_CMPLX:
356 pstate->wrap2<fortran_cmplx_operation> ();
359 gdb_assert_not_reached ("unhandled intrinsic");
368 { pstate->arglist_len = 1; }
372 { pstate->arglist_len = 1; }
375 arglist : arglist ',' exp %prec ABOVE_COMMA
376 { pstate->arglist_len++; }
379 arglist : arglist ',' subrange %prec ABOVE_COMMA
380 { pstate->arglist_len++; }
383 /* There are four sorts of subrange types in F90. */
385 subrange: exp ':' exp %prec ABOVE_COMMA
387 operation_up high = pstate->pop ();
388 operation_up low = pstate->pop ();
389 pstate->push_new<fortran_range_operation>
390 (RANGE_STANDARD, std::move (low),
391 std::move (high), operation_up ());
395 subrange: exp ':' %prec ABOVE_COMMA
397 operation_up low = pstate->pop ();
398 pstate->push_new<fortran_range_operation>
399 (RANGE_HIGH_BOUND_DEFAULT, std::move (low),
400 operation_up (), operation_up ());
404 subrange: ':' exp %prec ABOVE_COMMA
406 operation_up high = pstate->pop ();
407 pstate->push_new<fortran_range_operation>
408 (RANGE_LOW_BOUND_DEFAULT, operation_up (),
409 std::move (high), operation_up ());
413 subrange: ':' %prec ABOVE_COMMA
415 pstate->push_new<fortran_range_operation>
416 (RANGE_LOW_BOUND_DEFAULT
417 | RANGE_HIGH_BOUND_DEFAULT,
418 operation_up (), operation_up (),
423 /* And each of the four subrange types can also have a stride. */
424 subrange: exp ':' exp ':' exp %prec ABOVE_COMMA
426 operation_up stride = pstate->pop ();
427 operation_up high = pstate->pop ();
428 operation_up low = pstate->pop ();
429 pstate->push_new<fortran_range_operation>
430 (RANGE_STANDARD | RANGE_HAS_STRIDE,
431 std::move (low), std::move (high),
436 subrange: exp ':' ':' exp %prec ABOVE_COMMA
438 operation_up stride = pstate->pop ();
439 operation_up low = pstate->pop ();
440 pstate->push_new<fortran_range_operation>
441 (RANGE_HIGH_BOUND_DEFAULT
443 std::move (low), operation_up (),
448 subrange: ':' exp ':' exp %prec ABOVE_COMMA
450 operation_up stride = pstate->pop ();
451 operation_up high = pstate->pop ();
452 pstate->push_new<fortran_range_operation>
453 (RANGE_LOW_BOUND_DEFAULT
455 operation_up (), std::move (high),
460 subrange: ':' ':' exp %prec ABOVE_COMMA
462 operation_up stride = pstate->pop ();
463 pstate->push_new<fortran_range_operation>
464 (RANGE_LOW_BOUND_DEFAULT
465 | RANGE_HIGH_BOUND_DEFAULT
467 operation_up (), operation_up (),
472 complexnum: exp ',' exp
476 exp : '(' complexnum ')'
478 operation_up rhs = pstate->pop ();
479 operation_up lhs = pstate->pop ();
480 pstate->push_new<complex_operation>
481 (std::move (lhs), std::move (rhs),
482 parse_f_type (pstate)->builtin_complex_s16);
486 exp : '(' type ')' exp %prec UNARY
488 pstate->push_new<unop_cast_operation>
489 (pstate->pop (), $2);
495 pstate->push_new<fortran_structop_operation>
496 (pstate->pop (), copy_name ($3));
500 exp : exp '%' name COMPLETE
502 structop_base_operation *op
503 = new fortran_structop_operation (pstate->pop (),
505 pstate->mark_struct_expression (op);
506 pstate->push (operation_up (op));
510 exp : exp '%' COMPLETE
512 structop_base_operation *op
513 = new fortran_structop_operation (pstate->pop (),
515 pstate->mark_struct_expression (op);
516 pstate->push (operation_up (op));
520 /* Binary operators in order of decreasing precedence. */
523 { pstate->wrap2<repeat_operation> (); }
526 exp : exp STARSTAR exp
527 { pstate->wrap2<exp_operation> (); }
531 { pstate->wrap2<mul_operation> (); }
535 { pstate->wrap2<div_operation> (); }
539 { pstate->wrap2<add_operation> (); }
543 { pstate->wrap2<sub_operation> (); }
547 { pstate->wrap2<lsh_operation> (); }
551 { pstate->wrap2<rsh_operation> (); }
555 { pstate->wrap2<equal_operation> (); }
558 exp : exp NOTEQUAL exp
559 { pstate->wrap2<notequal_operation> (); }
563 { pstate->wrap2<leq_operation> (); }
567 { pstate->wrap2<geq_operation> (); }
570 exp : exp LESSTHAN exp
571 { pstate->wrap2<less_operation> (); }
574 exp : exp GREATERTHAN exp
575 { pstate->wrap2<gtr_operation> (); }
579 { pstate->wrap2<bitwise_and_operation> (); }
583 { pstate->wrap2<bitwise_xor_operation> (); }
587 { pstate->wrap2<bitwise_ior_operation> (); }
590 exp : exp BOOL_AND exp
591 { pstate->wrap2<logical_and_operation> (); }
595 exp : exp BOOL_OR exp
596 { pstate->wrap2<logical_or_operation> (); }
600 { pstate->wrap2<assign_operation> (); }
603 exp : exp ASSIGN_MODIFY exp
605 operation_up rhs = pstate->pop ();
606 operation_up lhs = pstate->pop ();
607 pstate->push_new<assign_modify_operation>
608 ($2, std::move (lhs), std::move (rhs));
614 pstate->push_new<long_const_operation>
621 parse_number (pstate, $1.stoken.ptr,
622 $1.stoken.length, 0, &val);
623 pstate->push_new<long_const_operation>
632 std::copy (std::begin ($1.val), std::end ($1.val),
634 pstate->push_new<float_const_operation> ($1.type, data);
641 exp : DOLLAR_VARIABLE
642 { pstate->push_dollar ($1); }
645 exp : SIZEOF '(' type ')' %prec UNARY
647 $3 = check_typedef ($3);
648 pstate->push_new<long_const_operation>
649 (parse_f_type (pstate)->builtin_integer,
654 exp : BOOLEAN_LITERAL
655 { pstate->push_new<bool_operation> ($1); }
660 pstate->push_new<string_operation>
665 variable: name_not_typename
666 { struct block_symbol sym = $1.sym;
667 std::string name = copy_name ($1.stoken);
668 pstate->push_symbol (name.c_str (), sym);
679 /* This is where the interesting stuff happens. */
682 struct type *follow_type = $1;
683 struct type *range_type;
686 switch (type_stack->pop ())
692 follow_type = lookup_pointer_type (follow_type);
695 follow_type = lookup_lvalue_reference_type (follow_type);
698 array_size = type_stack->pop_int ();
699 if (array_size != -1)
702 create_static_range_type ((struct type *) NULL,
703 parse_f_type (pstate)
707 create_array_type ((struct type *) NULL,
708 follow_type, range_type);
711 follow_type = lookup_pointer_type (follow_type);
714 follow_type = lookup_function_type (follow_type);
718 int kind_val = type_stack->pop_int ();
720 = convert_to_kind_type (follow_type, kind_val);
729 { type_stack->push (tp_pointer); $$ = 0; }
731 { type_stack->push (tp_pointer); $$ = $2; }
733 { type_stack->push (tp_reference); $$ = 0; }
735 { type_stack->push (tp_reference); $$ = $2; }
739 direct_abs_decl: '(' abs_decl ')'
741 | '(' KIND '=' INT ')'
742 { push_kind_type ($4.val, $4.type); }
744 { push_kind_type ($2.val, $2.type); }
745 | direct_abs_decl func_mod
746 { type_stack->push (tp_function); }
748 { type_stack->push (tp_function); }
753 | '(' nonempty_typelist ')'
754 { free ($2); $$ = 0; }
757 typebase /* Implements (approximately): (type-qualifier)* type-specifier */
761 { $$ = parse_f_type (pstate)->builtin_integer; }
763 { $$ = parse_f_type (pstate)->builtin_integer_s2; }
765 { $$ = parse_f_type (pstate)->builtin_character; }
767 { $$ = parse_f_type (pstate)->builtin_logical_s8; }
769 { $$ = parse_f_type (pstate)->builtin_logical; }
771 { $$ = parse_f_type (pstate)->builtin_logical_s2; }
773 { $$ = parse_f_type (pstate)->builtin_logical_s1; }
775 { $$ = parse_f_type (pstate)->builtin_real; }
777 { $$ = parse_f_type (pstate)->builtin_real_s8; }
779 { $$ = parse_f_type (pstate)->builtin_real_s16; }
781 { $$ = parse_f_type (pstate)->builtin_complex_s8; }
783 { $$ = parse_f_type (pstate)->builtin_complex_s8; }
784 | COMPLEX_S16_KEYWORD
785 { $$ = parse_f_type (pstate)->builtin_complex_s16; }
786 | COMPLEX_S32_KEYWORD
787 { $$ = parse_f_type (pstate)->builtin_complex_s32; }
789 { $$ = parse_f_type (pstate)->builtin_real;}
791 { $$ = parse_f_type (pstate)->builtin_real_s8;}
792 | SINGLE COMPLEX_KEYWORD
793 { $$ = parse_f_type (pstate)->builtin_complex_s8;}
794 | DOUBLE COMPLEX_KEYWORD
795 { $$ = parse_f_type (pstate)->builtin_complex_s16;}
800 { $$ = (struct type **) malloc (sizeof (struct type *) * 2);
801 $<ivec>$[0] = 1; /* Number of types in vector */
804 | nonempty_typelist ',' type
805 { int len = sizeof (struct type *) * (++($<ivec>1[0]) + 1);
806 $$ = (struct type **) realloc ((char *) $1, len);
807 $$[$<ivec>$[0]] = $3;
818 name_not_typename : NAME
819 /* These would be useful if name_not_typename was useful, but it is just
820 a fake for "variable", so these cause reduce/reduce conflicts because
821 the parser can't tell whether NAME_OR_INT is a name_not_typename (=variable,
822 =exp) or just an exp. If name_not_typename was ever used in an lvalue
823 context where only a name could occur, this might be useful.
830 /* Take care of parsing a number (anything that starts with a digit).
831 Set yylval and return the token type; update lexptr.
832 LEN is the number of characters in it. */
834 /*** Needs some error checking for the float case ***/
837 parse_number (struct parser_state *par_state,
838 const char *p, int len, int parsed_float, YYSTYPE *putithere)
843 int base = input_radix;
847 struct type *signed_type;
848 struct type *unsigned_type;
852 /* It's a float since it contains a point or an exponent. */
853 /* [dD] is not understood as an exponent by parse_float,
858 for (tmp2 = tmp; *tmp2; ++tmp2)
859 if (*tmp2 == 'd' || *tmp2 == 'D')
862 /* FIXME: Should this use different types? */
863 putithere->typed_val_float.type = parse_f_type (pstate)->builtin_real_s8;
864 bool parsed = parse_float (tmp, len,
865 putithere->typed_val_float.type,
866 putithere->typed_val_float.val);
868 return parsed? FLOAT : ERROR;
871 /* Handle base-switching prefixes 0x, 0t, 0d, 0 */
872 if (p[0] == '0' && len > 1)
907 if (len == 0 && c == 'l')
909 else if (len == 0 && c == 'u')
914 if (c >= '0' && c <= '9')
916 else if (c >= 'a' && c <= 'f')
919 return ERROR; /* Char not a digit */
921 return ERROR; /* Invalid digit in this base */
925 /* Portably test for overflow (only works for nonzero values, so make
926 a second check for zero). */
927 if ((prevn >= n) && n != 0)
928 unsigned_p=1; /* Try something unsigned */
929 /* If range checking enabled, portably test for unsigned overflow. */
930 if (RANGE_CHECK && n != 0)
932 if ((unsigned_p && prevn >= n))
933 range_error (_("Overflow on numeric constant."));
938 /* If the number is too big to be an int, or it's got an l suffix
939 then it's a long. Work out if this has to be a long by
940 shifting right and seeing if anything remains, and the
941 target int size is different to the target long size.
943 In the expression below, we could have tested
944 (n >> gdbarch_int_bit (parse_gdbarch))
945 to see if it was zero,
946 but too many compilers warn about that, when ints and longs
947 are the same size. So we shift it twice, with fewer bits
948 each time, for the same result. */
950 if ((gdbarch_int_bit (par_state->gdbarch ())
951 != gdbarch_long_bit (par_state->gdbarch ())
953 >> (gdbarch_int_bit (par_state->gdbarch ())-2))) /* Avoid
957 high_bit = ((ULONGEST)1)
958 << (gdbarch_long_bit (par_state->gdbarch ())-1);
959 unsigned_type = parse_type (par_state)->builtin_unsigned_long;
960 signed_type = parse_type (par_state)->builtin_long;
965 ((ULONGEST)1) << (gdbarch_int_bit (par_state->gdbarch ()) - 1);
966 unsigned_type = parse_type (par_state)->builtin_unsigned_int;
967 signed_type = parse_type (par_state)->builtin_int;
970 putithere->typed_val.val = n;
972 /* If the high bit of the worked out type is set then this number
973 has to be unsigned. */
975 if (unsigned_p || (n & high_bit))
976 putithere->typed_val.type = unsigned_type;
978 putithere->typed_val.type = signed_type;
983 /* Called to setup the type stack when we encounter a '(kind=N)' type
984 modifier, performs some bounds checking on 'N' and then pushes this to
985 the type stack followed by the 'tp_kind' marker. */
987 push_kind_type (LONGEST val, struct type *type)
991 if (type->is_unsigned ())
993 ULONGEST uval = static_cast <ULONGEST> (val);
995 error (_("kind value out of range"));
996 ival = static_cast <int> (uval);
1000 if (val > INT_MAX || val < 0)
1001 error (_("kind value out of range"));
1002 ival = static_cast <int> (val);
1005 type_stack->push (ival);
1006 type_stack->push (tp_kind);
1009 /* Called when a type has a '(kind=N)' modifier after it, for example
1010 'character(kind=1)'. The BASETYPE is the type described by 'character'
1011 in our example, and KIND is the integer '1'. This function returns a
1012 new type that represents the basetype of a specific kind. */
1013 static struct type *
1014 convert_to_kind_type (struct type *basetype, int kind)
1016 if (basetype == parse_f_type (pstate)->builtin_character)
1018 /* Character of kind 1 is a special case, this is the same as the
1019 base character type. */
1021 return parse_f_type (pstate)->builtin_character;
1023 else if (basetype == parse_f_type (pstate)->builtin_complex_s8)
1026 return parse_f_type (pstate)->builtin_complex_s8;
1028 return parse_f_type (pstate)->builtin_complex_s16;
1029 else if (kind == 16)
1030 return parse_f_type (pstate)->builtin_complex_s32;
1032 else if (basetype == parse_f_type (pstate)->builtin_real)
1035 return parse_f_type (pstate)->builtin_real;
1037 return parse_f_type (pstate)->builtin_real_s8;
1038 else if (kind == 16)
1039 return parse_f_type (pstate)->builtin_real_s16;
1041 else if (basetype == parse_f_type (pstate)->builtin_logical)
1044 return parse_f_type (pstate)->builtin_logical_s1;
1046 return parse_f_type (pstate)->builtin_logical_s2;
1048 return parse_f_type (pstate)->builtin_logical;
1050 return parse_f_type (pstate)->builtin_logical_s8;
1052 else if (basetype == parse_f_type (pstate)->builtin_integer)
1055 return parse_f_type (pstate)->builtin_integer_s1;
1057 return parse_f_type (pstate)->builtin_integer_s2;
1059 return parse_f_type (pstate)->builtin_integer;
1061 return parse_f_type (pstate)->builtin_integer_s8;
1064 error (_("unsupported kind %d for type %s"),
1065 kind, TYPE_SAFE_NAME (basetype));
1067 /* Should never get here. */
1073 /* The string to match against. */
1076 /* The lexer token to return. */
1079 /* The expression opcode to embed within the token. */
1080 enum exp_opcode opcode;
1082 /* When this is true the string in OPER is matched exactly including
1083 case, when this is false OPER is matched case insensitively. */
1084 bool case_sensitive;
1087 /* List of Fortran operators. */
1089 static const struct token fortran_operators[] =
1091 { ".and.", BOOL_AND, OP_NULL, false },
1092 { ".or.", BOOL_OR, OP_NULL, false },
1093 { ".not.", BOOL_NOT, OP_NULL, false },
1094 { ".eq.", EQUAL, OP_NULL, false },
1095 { ".eqv.", EQUAL, OP_NULL, false },
1096 { ".neqv.", NOTEQUAL, OP_NULL, false },
1097 { ".xor.", NOTEQUAL, OP_NULL, false },
1098 { "==", EQUAL, OP_NULL, false },
1099 { ".ne.", NOTEQUAL, OP_NULL, false },
1100 { "/=", NOTEQUAL, OP_NULL, false },
1101 { ".le.", LEQ, OP_NULL, false },
1102 { "<=", LEQ, OP_NULL, false },
1103 { ".ge.", GEQ, OP_NULL, false },
1104 { ">=", GEQ, OP_NULL, false },
1105 { ".gt.", GREATERTHAN, OP_NULL, false },
1106 { ">", GREATERTHAN, OP_NULL, false },
1107 { ".lt.", LESSTHAN, OP_NULL, false },
1108 { "<", LESSTHAN, OP_NULL, false },
1109 { "**", STARSTAR, BINOP_EXP, false },
1112 /* Holds the Fortran representation of a boolean, and the integer value we
1113 substitute in when one of the matching strings is parsed. */
1114 struct f77_boolean_val
1116 /* The string representing a Fortran boolean. */
1119 /* The integer value to replace it with. */
1123 /* The set of Fortran booleans. These are matched case insensitively. */
1124 static const struct f77_boolean_val boolean_values[] =
1130 static const struct token f77_keywords[] =
1132 /* Historically these have always been lowercase only in GDB. */
1133 { "complex_16", COMPLEX_S16_KEYWORD, OP_NULL, true },
1134 { "complex_32", COMPLEX_S32_KEYWORD, OP_NULL, true },
1135 { "character", CHARACTER, OP_NULL, true },
1136 { "integer_2", INT_S2_KEYWORD, OP_NULL, true },
1137 { "logical_1", LOGICAL_S1_KEYWORD, OP_NULL, true },
1138 { "logical_2", LOGICAL_S2_KEYWORD, OP_NULL, true },
1139 { "logical_8", LOGICAL_S8_KEYWORD, OP_NULL, true },
1140 { "complex_8", COMPLEX_S8_KEYWORD, OP_NULL, true },
1141 { "integer", INT_KEYWORD, OP_NULL, true },
1142 { "logical", LOGICAL_KEYWORD, OP_NULL, true },
1143 { "real_16", REAL_S16_KEYWORD, OP_NULL, true },
1144 { "complex", COMPLEX_KEYWORD, OP_NULL, true },
1145 { "sizeof", SIZEOF, OP_NULL, true },
1146 { "real_8", REAL_S8_KEYWORD, OP_NULL, true },
1147 { "real", REAL_KEYWORD, OP_NULL, true },
1148 { "single", SINGLE, OP_NULL, true },
1149 { "double", DOUBLE, OP_NULL, true },
1150 { "precision", PRECISION, OP_NULL, true },
1151 /* The following correspond to actual functions in Fortran and are case
1153 { "kind", KIND, OP_NULL, false },
1154 { "abs", UNOP_INTRINSIC, UNOP_ABS, false },
1155 { "mod", BINOP_INTRINSIC, BINOP_MOD, false },
1156 { "floor", UNOP_INTRINSIC, UNOP_FORTRAN_FLOOR, false },
1157 { "ceiling", UNOP_INTRINSIC, UNOP_FORTRAN_CEILING, false },
1158 { "modulo", BINOP_INTRINSIC, BINOP_FORTRAN_MODULO, false },
1159 { "cmplx", BINOP_INTRINSIC, BINOP_FORTRAN_CMPLX, false },
1160 { "lbound", UNOP_OR_BINOP_INTRINSIC, FORTRAN_LBOUND, false },
1161 { "ubound", UNOP_OR_BINOP_INTRINSIC, FORTRAN_UBOUND, false },
1162 { "allocated", UNOP_INTRINSIC, UNOP_FORTRAN_ALLOCATED, false },
1163 { "associated", UNOP_OR_BINOP_INTRINSIC, FORTRAN_ASSOCIATED, false },
1164 { "rank", UNOP_INTRINSIC, UNOP_FORTRAN_RANK, false },
1165 { "size", UNOP_OR_BINOP_INTRINSIC, FORTRAN_ARRAY_SIZE, false },
1166 { "shape", UNOP_INTRINSIC, UNOP_FORTRAN_SHAPE, false },
1167 { "loc", UNOP_INTRINSIC, UNOP_FORTRAN_LOC, false },
1170 /* Implementation of a dynamically expandable buffer for processing input
1171 characters acquired through lexptr and building a value to return in
1172 yylval. Ripped off from ch-exp.y */
1174 static char *tempbuf; /* Current buffer contents */
1175 static int tempbufsize; /* Size of allocated buffer */
1176 static int tempbufindex; /* Current index into buffer */
1178 #define GROWBY_MIN_SIZE 64 /* Minimum amount to grow buffer by */
1180 #define CHECKBUF(size) \
1182 if (tempbufindex + (size) >= tempbufsize) \
1184 growbuf_by_size (size); \
1189 /* Grow the static temp buffer if necessary, including allocating the
1190 first one on demand. */
1193 growbuf_by_size (int count)
1197 growby = std::max (count, GROWBY_MIN_SIZE);
1198 tempbufsize += growby;
1199 if (tempbuf == NULL)
1200 tempbuf = (char *) malloc (tempbufsize);
1202 tempbuf = (char *) realloc (tempbuf, tempbufsize);
1205 /* Blatantly ripped off from ch-exp.y. This routine recognizes F77
1208 Recognize a string literal. A string literal is a nonzero sequence
1209 of characters enclosed in matching single quotes, except that
1210 a single character inside single quotes is a character literal, which
1211 we reject as a string literal. To embed the terminator character inside
1212 a string, it is simply doubled (I.E. 'this''is''one''string') */
1215 match_string_literal (void)
1217 const char *tokptr = pstate->lexptr;
1219 for (tempbufindex = 0, tokptr++; *tokptr != '\0'; tokptr++)
1222 if (*tokptr == *pstate->lexptr)
1224 if (*(tokptr + 1) == *pstate->lexptr)
1229 tempbuf[tempbufindex++] = *tokptr;
1231 if (*tokptr == '\0' /* no terminator */
1232 || tempbufindex == 0) /* no string */
1236 tempbuf[tempbufindex] = '\0';
1237 yylval.sval.ptr = tempbuf;
1238 yylval.sval.length = tempbufindex;
1239 pstate->lexptr = ++tokptr;
1240 return STRING_LITERAL;
1244 /* This is set if a NAME token appeared at the very end of the input
1245 string, with no whitespace separating the name from the EOF. This
1246 is used only when parsing to do field name completion. */
1247 static bool saw_name_at_eof;
1249 /* This is set if the previously-returned token was a structure
1251 static bool last_was_structop;
1253 /* Read one token, getting characters through lexptr. */
1261 const char *tokstart;
1262 bool saw_structop = last_was_structop;
1264 last_was_structop = false;
1268 pstate->prev_lexptr = pstate->lexptr;
1270 tokstart = pstate->lexptr;
1272 /* First of all, let us make sure we are not dealing with the
1273 special tokens .true. and .false. which evaluate to 1 and 0. */
1275 if (*pstate->lexptr == '.')
1277 for (const auto &candidate : boolean_values)
1279 if (strncasecmp (tokstart, candidate.name,
1280 strlen (candidate.name)) == 0)
1282 pstate->lexptr += strlen (candidate.name);
1283 yylval.lval = candidate.value;
1284 return BOOLEAN_LITERAL;
1289 /* See if it is a Fortran operator. */
1290 for (const auto &candidate : fortran_operators)
1291 if (strncasecmp (tokstart, candidate.oper,
1292 strlen (candidate.oper)) == 0)
1294 gdb_assert (!candidate.case_sensitive);
1295 pstate->lexptr += strlen (candidate.oper);
1296 yylval.opcode = candidate.opcode;
1297 return candidate.token;
1300 switch (c = *tokstart)
1303 if (saw_name_at_eof)
1305 saw_name_at_eof = false;
1308 else if (pstate->parse_completion && saw_structop)
1319 token = match_string_literal ();
1330 if (paren_depth == 0)
1337 if (pstate->comma_terminates && paren_depth == 0)
1343 /* Might be a floating point number. */
1344 if (pstate->lexptr[1] < '0' || pstate->lexptr[1] > '9')
1345 goto symbol; /* Nope, must be a symbol. */
1359 /* It's a number. */
1360 int got_dot = 0, got_e = 0, got_d = 0, toktype;
1361 const char *p = tokstart;
1362 int hex = input_radix > 10;
1364 if (c == '0' && (p[1] == 'x' || p[1] == 'X'))
1369 else if (c == '0' && (p[1]=='t' || p[1]=='T'
1370 || p[1]=='d' || p[1]=='D'))
1378 if (!hex && !got_e && (*p == 'e' || *p == 'E'))
1379 got_dot = got_e = 1;
1380 else if (!hex && !got_d && (*p == 'd' || *p == 'D'))
1381 got_dot = got_d = 1;
1382 else if (!hex && !got_dot && *p == '.')
1384 else if (((got_e && (p[-1] == 'e' || p[-1] == 'E'))
1385 || (got_d && (p[-1] == 'd' || p[-1] == 'D')))
1386 && (*p == '-' || *p == '+'))
1387 /* This is the sign of the exponent, not the end of the
1390 /* We will take any letters or digits. parse_number will
1391 complain if past the radix, or if L or U are not final. */
1392 else if ((*p < '0' || *p > '9')
1393 && ((*p < 'a' || *p > 'z')
1394 && (*p < 'A' || *p > 'Z')))
1397 toktype = parse_number (pstate, tokstart, p - tokstart,
1398 got_dot|got_e|got_d,
1400 if (toktype == ERROR)
1402 char *err_copy = (char *) alloca (p - tokstart + 1);
1404 memcpy (err_copy, tokstart, p - tokstart);
1405 err_copy[p - tokstart] = 0;
1406 error (_("Invalid number \"%s\"."), err_copy);
1413 last_was_structop = true;
1439 if (!(c == '_' || c == '$' || c ==':'
1440 || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')))
1441 /* We must have come across a bad character (e.g. ';'). */
1442 error (_("Invalid character '%c' in expression."), c);
1445 for (c = tokstart[namelen];
1446 (c == '_' || c == '$' || c == ':' || (c >= '0' && c <= '9')
1447 || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'));
1448 c = tokstart[++namelen]);
1450 /* The token "if" terminates the expression and is NOT
1451 removed from the input stream. */
1453 if (namelen == 2 && tokstart[0] == 'i' && tokstart[1] == 'f')
1456 pstate->lexptr += namelen;
1458 /* Catch specific keywords. */
1460 for (const auto &keyword : f77_keywords)
1461 if (strlen (keyword.oper) == namelen
1462 && ((!keyword.case_sensitive
1463 && strncasecmp (tokstart, keyword.oper, namelen) == 0)
1464 || (keyword.case_sensitive
1465 && strncmp (tokstart, keyword.oper, namelen) == 0)))
1467 yylval.opcode = keyword.opcode;
1468 return keyword.token;
1471 yylval.sval.ptr = tokstart;
1472 yylval.sval.length = namelen;
1474 if (*tokstart == '$')
1475 return DOLLAR_VARIABLE;
1477 /* Use token-type TYPENAME for symbols that happen to be defined
1478 currently as names of types; NAME for other symbols.
1479 The caller is not constrained to care about the distinction. */
1481 std::string tmp = copy_name (yylval.sval);
1482 struct block_symbol result;
1483 const enum domain_enum_tag lookup_domains[] =
1491 for (const auto &domain : lookup_domains)
1493 result = lookup_symbol (tmp.c_str (), pstate->expression_context_block,
1495 if (result.symbol && result.symbol->aclass () == LOC_TYPEDEF)
1497 yylval.tsym.type = result.symbol->type ();
1506 = language_lookup_primitive_type (pstate->language (),
1507 pstate->gdbarch (), tmp.c_str ());
1508 if (yylval.tsym.type != NULL)
1511 /* Input names that aren't symbols but ARE valid hex numbers,
1512 when the input radix permits them, can be names or numbers
1513 depending on the parse. Note we support radixes > 16 here. */
1515 && ((tokstart[0] >= 'a' && tokstart[0] < 'a' + input_radix - 10)
1516 || (tokstart[0] >= 'A' && tokstart[0] < 'A' + input_radix - 10)))
1518 YYSTYPE newlval; /* Its value is ignored. */
1519 hextype = parse_number (pstate, tokstart, namelen, 0, &newlval);
1522 yylval.ssym.sym = result;
1523 yylval.ssym.is_a_field_of_this = false;
1528 if (pstate->parse_completion && *pstate->lexptr == '\0')
1529 saw_name_at_eof = true;
1531 /* Any other kind of symbol */
1532 yylval.ssym.sym = result;
1533 yylval.ssym.is_a_field_of_this = false;
1539 f_language::parser (struct parser_state *par_state) const
1541 /* Setting up the parser state. */
1542 scoped_restore pstate_restore = make_scoped_restore (&pstate);
1543 scoped_restore restore_yydebug = make_scoped_restore (&yydebug,
1545 gdb_assert (par_state != NULL);
1547 last_was_structop = false;
1548 saw_name_at_eof = false;
1551 struct type_stack stack;
1552 scoped_restore restore_type_stack = make_scoped_restore (&type_stack,
1555 int result = yyparse ();
1557 pstate->set_operation (pstate->pop ());
1562 yyerror (const char *msg)
1564 if (pstate->prev_lexptr)
1565 pstate->lexptr = pstate->prev_lexptr;
1567 error (_("A %s in expression, near `%s'."), msg, pstate->lexptr);