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 */
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 && (unsigned)prevn >= (unsigned)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_s2;
1057 return parse_f_type (pstate)->builtin_integer;
1059 return parse_f_type (pstate)->builtin_integer_s8;
1062 error (_("unsupported kind %d for type %s"),
1063 kind, TYPE_SAFE_NAME (basetype));
1065 /* Should never get here. */
1071 /* The string to match against. */
1074 /* The lexer token to return. */
1077 /* The expression opcode to embed within the token. */
1078 enum exp_opcode opcode;
1080 /* When this is true the string in OPER is matched exactly including
1081 case, when this is false OPER is matched case insensitively. */
1082 bool case_sensitive;
1085 /* List of Fortran operators. */
1087 static const struct token fortran_operators[] =
1089 { ".and.", BOOL_AND, OP_NULL, false },
1090 { ".or.", BOOL_OR, OP_NULL, false },
1091 { ".not.", BOOL_NOT, OP_NULL, false },
1092 { ".eq.", EQUAL, OP_NULL, false },
1093 { ".eqv.", EQUAL, OP_NULL, false },
1094 { ".neqv.", NOTEQUAL, OP_NULL, false },
1095 { ".xor.", NOTEQUAL, OP_NULL, false },
1096 { "==", EQUAL, OP_NULL, false },
1097 { ".ne.", NOTEQUAL, OP_NULL, false },
1098 { "/=", NOTEQUAL, OP_NULL, false },
1099 { ".le.", LEQ, OP_NULL, false },
1100 { "<=", LEQ, OP_NULL, false },
1101 { ".ge.", GEQ, OP_NULL, false },
1102 { ">=", GEQ, OP_NULL, false },
1103 { ".gt.", GREATERTHAN, OP_NULL, false },
1104 { ">", GREATERTHAN, OP_NULL, false },
1105 { ".lt.", LESSTHAN, OP_NULL, false },
1106 { "<", LESSTHAN, OP_NULL, false },
1107 { "**", STARSTAR, BINOP_EXP, false },
1110 /* Holds the Fortran representation of a boolean, and the integer value we
1111 substitute in when one of the matching strings is parsed. */
1112 struct f77_boolean_val
1114 /* The string representing a Fortran boolean. */
1117 /* The integer value to replace it with. */
1121 /* The set of Fortran booleans. These are matched case insensitively. */
1122 static const struct f77_boolean_val boolean_values[] =
1128 static const struct token f77_keywords[] =
1130 /* Historically these have always been lowercase only in GDB. */
1131 { "complex_16", COMPLEX_S16_KEYWORD, OP_NULL, true },
1132 { "complex_32", COMPLEX_S32_KEYWORD, OP_NULL, true },
1133 { "character", CHARACTER, OP_NULL, true },
1134 { "integer_2", INT_S2_KEYWORD, OP_NULL, true },
1135 { "logical_1", LOGICAL_S1_KEYWORD, OP_NULL, true },
1136 { "logical_2", LOGICAL_S2_KEYWORD, OP_NULL, true },
1137 { "logical_8", LOGICAL_S8_KEYWORD, OP_NULL, true },
1138 { "complex_8", COMPLEX_S8_KEYWORD, OP_NULL, true },
1139 { "integer", INT_KEYWORD, OP_NULL, true },
1140 { "logical", LOGICAL_KEYWORD, OP_NULL, true },
1141 { "real_16", REAL_S16_KEYWORD, OP_NULL, true },
1142 { "complex", COMPLEX_KEYWORD, OP_NULL, true },
1143 { "sizeof", SIZEOF, OP_NULL, true },
1144 { "real_8", REAL_S8_KEYWORD, OP_NULL, true },
1145 { "real", REAL_KEYWORD, OP_NULL, true },
1146 { "single", SINGLE, OP_NULL, true },
1147 { "double", DOUBLE, OP_NULL, true },
1148 { "precision", PRECISION, OP_NULL, true },
1149 /* The following correspond to actual functions in Fortran and are case
1151 { "kind", KIND, OP_NULL, false },
1152 { "abs", UNOP_INTRINSIC, UNOP_ABS, false },
1153 { "mod", BINOP_INTRINSIC, BINOP_MOD, false },
1154 { "floor", UNOP_INTRINSIC, UNOP_FORTRAN_FLOOR, false },
1155 { "ceiling", UNOP_INTRINSIC, UNOP_FORTRAN_CEILING, false },
1156 { "modulo", BINOP_INTRINSIC, BINOP_FORTRAN_MODULO, false },
1157 { "cmplx", BINOP_INTRINSIC, BINOP_FORTRAN_CMPLX, false },
1158 { "lbound", UNOP_OR_BINOP_INTRINSIC, FORTRAN_LBOUND, false },
1159 { "ubound", UNOP_OR_BINOP_INTRINSIC, FORTRAN_UBOUND, false },
1160 { "allocated", UNOP_INTRINSIC, UNOP_FORTRAN_ALLOCATED, false },
1161 { "associated", UNOP_OR_BINOP_INTRINSIC, FORTRAN_ASSOCIATED, false },
1162 { "rank", UNOP_INTRINSIC, UNOP_FORTRAN_RANK, false },
1163 { "size", UNOP_OR_BINOP_INTRINSIC, FORTRAN_ARRAY_SIZE, false },
1164 { "shape", UNOP_INTRINSIC, UNOP_FORTRAN_SHAPE, false },
1165 { "loc", UNOP_INTRINSIC, UNOP_FORTRAN_LOC, false },
1168 /* Implementation of a dynamically expandable buffer for processing input
1169 characters acquired through lexptr and building a value to return in
1170 yylval. Ripped off from ch-exp.y */
1172 static char *tempbuf; /* Current buffer contents */
1173 static int tempbufsize; /* Size of allocated buffer */
1174 static int tempbufindex; /* Current index into buffer */
1176 #define GROWBY_MIN_SIZE 64 /* Minimum amount to grow buffer by */
1178 #define CHECKBUF(size) \
1180 if (tempbufindex + (size) >= tempbufsize) \
1182 growbuf_by_size (size); \
1187 /* Grow the static temp buffer if necessary, including allocating the
1188 first one on demand. */
1191 growbuf_by_size (int count)
1195 growby = std::max (count, GROWBY_MIN_SIZE);
1196 tempbufsize += growby;
1197 if (tempbuf == NULL)
1198 tempbuf = (char *) malloc (tempbufsize);
1200 tempbuf = (char *) realloc (tempbuf, tempbufsize);
1203 /* Blatantly ripped off from ch-exp.y. This routine recognizes F77
1206 Recognize a string literal. A string literal is a nonzero sequence
1207 of characters enclosed in matching single quotes, except that
1208 a single character inside single quotes is a character literal, which
1209 we reject as a string literal. To embed the terminator character inside
1210 a string, it is simply doubled (I.E. 'this''is''one''string') */
1213 match_string_literal (void)
1215 const char *tokptr = pstate->lexptr;
1217 for (tempbufindex = 0, tokptr++; *tokptr != '\0'; tokptr++)
1220 if (*tokptr == *pstate->lexptr)
1222 if (*(tokptr + 1) == *pstate->lexptr)
1227 tempbuf[tempbufindex++] = *tokptr;
1229 if (*tokptr == '\0' /* no terminator */
1230 || tempbufindex == 0) /* no string */
1234 tempbuf[tempbufindex] = '\0';
1235 yylval.sval.ptr = tempbuf;
1236 yylval.sval.length = tempbufindex;
1237 pstate->lexptr = ++tokptr;
1238 return STRING_LITERAL;
1242 /* This is set if a NAME token appeared at the very end of the input
1243 string, with no whitespace separating the name from the EOF. This
1244 is used only when parsing to do field name completion. */
1245 static bool saw_name_at_eof;
1247 /* This is set if the previously-returned token was a structure
1249 static bool last_was_structop;
1251 /* Read one token, getting characters through lexptr. */
1259 const char *tokstart;
1260 bool saw_structop = last_was_structop;
1262 last_was_structop = false;
1266 pstate->prev_lexptr = pstate->lexptr;
1268 tokstart = pstate->lexptr;
1270 /* First of all, let us make sure we are not dealing with the
1271 special tokens .true. and .false. which evaluate to 1 and 0. */
1273 if (*pstate->lexptr == '.')
1275 for (const auto &candidate : boolean_values)
1277 if (strncasecmp (tokstart, candidate.name,
1278 strlen (candidate.name)) == 0)
1280 pstate->lexptr += strlen (candidate.name);
1281 yylval.lval = candidate.value;
1282 return BOOLEAN_LITERAL;
1287 /* See if it is a Fortran operator. */
1288 for (const auto &candidate : fortran_operators)
1289 if (strncasecmp (tokstart, candidate.oper,
1290 strlen (candidate.oper)) == 0)
1292 gdb_assert (!candidate.case_sensitive);
1293 pstate->lexptr += strlen (candidate.oper);
1294 yylval.opcode = candidate.opcode;
1295 return candidate.token;
1298 switch (c = *tokstart)
1301 if (saw_name_at_eof)
1303 saw_name_at_eof = false;
1306 else if (pstate->parse_completion && saw_structop)
1317 token = match_string_literal ();
1328 if (paren_depth == 0)
1335 if (pstate->comma_terminates && paren_depth == 0)
1341 /* Might be a floating point number. */
1342 if (pstate->lexptr[1] < '0' || pstate->lexptr[1] > '9')
1343 goto symbol; /* Nope, must be a symbol. */
1357 /* It's a number. */
1358 int got_dot = 0, got_e = 0, got_d = 0, toktype;
1359 const char *p = tokstart;
1360 int hex = input_radix > 10;
1362 if (c == '0' && (p[1] == 'x' || p[1] == 'X'))
1367 else if (c == '0' && (p[1]=='t' || p[1]=='T'
1368 || p[1]=='d' || p[1]=='D'))
1376 if (!hex && !got_e && (*p == 'e' || *p == 'E'))
1377 got_dot = got_e = 1;
1378 else if (!hex && !got_d && (*p == 'd' || *p == 'D'))
1379 got_dot = got_d = 1;
1380 else if (!hex && !got_dot && *p == '.')
1382 else if (((got_e && (p[-1] == 'e' || p[-1] == 'E'))
1383 || (got_d && (p[-1] == 'd' || p[-1] == 'D')))
1384 && (*p == '-' || *p == '+'))
1385 /* This is the sign of the exponent, not the end of the
1388 /* We will take any letters or digits. parse_number will
1389 complain if past the radix, or if L or U are not final. */
1390 else if ((*p < '0' || *p > '9')
1391 && ((*p < 'a' || *p > 'z')
1392 && (*p < 'A' || *p > 'Z')))
1395 toktype = parse_number (pstate, tokstart, p - tokstart,
1396 got_dot|got_e|got_d,
1398 if (toktype == ERROR)
1400 char *err_copy = (char *) alloca (p - tokstart + 1);
1402 memcpy (err_copy, tokstart, p - tokstart);
1403 err_copy[p - tokstart] = 0;
1404 error (_("Invalid number \"%s\"."), err_copy);
1411 last_was_structop = true;
1437 if (!(c == '_' || c == '$' || c ==':'
1438 || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')))
1439 /* We must have come across a bad character (e.g. ';'). */
1440 error (_("Invalid character '%c' in expression."), c);
1443 for (c = tokstart[namelen];
1444 (c == '_' || c == '$' || c == ':' || (c >= '0' && c <= '9')
1445 || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'));
1446 c = tokstart[++namelen]);
1448 /* The token "if" terminates the expression and is NOT
1449 removed from the input stream. */
1451 if (namelen == 2 && tokstart[0] == 'i' && tokstart[1] == 'f')
1454 pstate->lexptr += namelen;
1456 /* Catch specific keywords. */
1458 for (const auto &keyword : f77_keywords)
1459 if (strlen (keyword.oper) == namelen
1460 && ((!keyword.case_sensitive
1461 && strncasecmp (tokstart, keyword.oper, namelen) == 0)
1462 || (keyword.case_sensitive
1463 && strncmp (tokstart, keyword.oper, namelen) == 0)))
1465 yylval.opcode = keyword.opcode;
1466 return keyword.token;
1469 yylval.sval.ptr = tokstart;
1470 yylval.sval.length = namelen;
1472 if (*tokstart == '$')
1473 return DOLLAR_VARIABLE;
1475 /* Use token-type TYPENAME for symbols that happen to be defined
1476 currently as names of types; NAME for other symbols.
1477 The caller is not constrained to care about the distinction. */
1479 std::string tmp = copy_name (yylval.sval);
1480 struct block_symbol result;
1481 const enum domain_enum_tag lookup_domains[] =
1489 for (const auto &domain : lookup_domains)
1491 result = lookup_symbol (tmp.c_str (), pstate->expression_context_block,
1493 if (result.symbol && result.symbol->aclass () == LOC_TYPEDEF)
1495 yylval.tsym.type = result.symbol->type ();
1504 = language_lookup_primitive_type (pstate->language (),
1505 pstate->gdbarch (), tmp.c_str ());
1506 if (yylval.tsym.type != NULL)
1509 /* Input names that aren't symbols but ARE valid hex numbers,
1510 when the input radix permits them, can be names or numbers
1511 depending on the parse. Note we support radixes > 16 here. */
1513 && ((tokstart[0] >= 'a' && tokstart[0] < 'a' + input_radix - 10)
1514 || (tokstart[0] >= 'A' && tokstart[0] < 'A' + input_radix - 10)))
1516 YYSTYPE newlval; /* Its value is ignored. */
1517 hextype = parse_number (pstate, tokstart, namelen, 0, &newlval);
1520 yylval.ssym.sym = result;
1521 yylval.ssym.is_a_field_of_this = false;
1526 if (pstate->parse_completion && *pstate->lexptr == '\0')
1527 saw_name_at_eof = true;
1529 /* Any other kind of symbol */
1530 yylval.ssym.sym = result;
1531 yylval.ssym.is_a_field_of_this = false;
1537 f_language::parser (struct parser_state *par_state) const
1539 /* Setting up the parser state. */
1540 scoped_restore pstate_restore = make_scoped_restore (&pstate);
1541 scoped_restore restore_yydebug = make_scoped_restore (&yydebug,
1543 gdb_assert (par_state != NULL);
1545 last_was_structop = false;
1546 saw_name_at_eof = false;
1549 struct type_stack stack;
1550 scoped_restore restore_type_stack = make_scoped_restore (&type_stack,
1553 int result = yyparse ();
1555 pstate->set_operation (pstate->pop ());
1560 yyerror (const char *msg)
1562 if (pstate->prev_lexptr)
1563 pstate->lexptr = pstate->prev_lexptr;
1565 error (_("A %s in expression, near `%s'."), msg, pstate->lexptr);