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> ();
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> ();
337 gdb_assert_not_reached ("unhandled intrinsic");
342 exp : BINOP_INTRINSIC '(' exp ',' exp ')'
347 pstate->wrap2<fortran_mod_operation> ();
349 case BINOP_FORTRAN_MODULO:
350 pstate->wrap2<fortran_modulo_operation> ();
352 case BINOP_FORTRAN_CMPLX:
353 pstate->wrap2<fortran_cmplx_operation> ();
356 gdb_assert_not_reached ("unhandled intrinsic");
365 { pstate->arglist_len = 1; }
369 { pstate->arglist_len = 1; }
372 arglist : arglist ',' exp %prec ABOVE_COMMA
373 { pstate->arglist_len++; }
376 arglist : arglist ',' subrange %prec ABOVE_COMMA
377 { pstate->arglist_len++; }
380 /* There are four sorts of subrange types in F90. */
382 subrange: exp ':' exp %prec ABOVE_COMMA
384 operation_up high = pstate->pop ();
385 operation_up low = pstate->pop ();
386 pstate->push_new<fortran_range_operation>
387 (RANGE_STANDARD, std::move (low),
388 std::move (high), operation_up ());
392 subrange: exp ':' %prec ABOVE_COMMA
394 operation_up low = pstate->pop ();
395 pstate->push_new<fortran_range_operation>
396 (RANGE_HIGH_BOUND_DEFAULT, std::move (low),
397 operation_up (), operation_up ());
401 subrange: ':' exp %prec ABOVE_COMMA
403 operation_up high = pstate->pop ();
404 pstate->push_new<fortran_range_operation>
405 (RANGE_LOW_BOUND_DEFAULT, operation_up (),
406 std::move (high), operation_up ());
410 subrange: ':' %prec ABOVE_COMMA
412 pstate->push_new<fortran_range_operation>
413 (RANGE_LOW_BOUND_DEFAULT
414 | RANGE_HIGH_BOUND_DEFAULT,
415 operation_up (), operation_up (),
420 /* And each of the four subrange types can also have a stride. */
421 subrange: exp ':' exp ':' exp %prec ABOVE_COMMA
423 operation_up stride = pstate->pop ();
424 operation_up high = pstate->pop ();
425 operation_up low = pstate->pop ();
426 pstate->push_new<fortran_range_operation>
427 (RANGE_STANDARD | RANGE_HAS_STRIDE,
428 std::move (low), std::move (high),
433 subrange: exp ':' ':' exp %prec ABOVE_COMMA
435 operation_up stride = pstate->pop ();
436 operation_up low = pstate->pop ();
437 pstate->push_new<fortran_range_operation>
438 (RANGE_HIGH_BOUND_DEFAULT
440 std::move (low), operation_up (),
445 subrange: ':' exp ':' exp %prec ABOVE_COMMA
447 operation_up stride = pstate->pop ();
448 operation_up high = pstate->pop ();
449 pstate->push_new<fortran_range_operation>
450 (RANGE_LOW_BOUND_DEFAULT
452 operation_up (), std::move (high),
457 subrange: ':' ':' exp %prec ABOVE_COMMA
459 operation_up stride = pstate->pop ();
460 pstate->push_new<fortran_range_operation>
461 (RANGE_LOW_BOUND_DEFAULT
462 | RANGE_HIGH_BOUND_DEFAULT
464 operation_up (), operation_up (),
469 complexnum: exp ',' exp
473 exp : '(' complexnum ')'
475 operation_up rhs = pstate->pop ();
476 operation_up lhs = pstate->pop ();
477 pstate->push_new<complex_operation>
478 (std::move (lhs), std::move (rhs),
479 parse_f_type (pstate)->builtin_complex_s16);
483 exp : '(' type ')' exp %prec UNARY
485 pstate->push_new<unop_cast_operation>
486 (pstate->pop (), $2);
492 pstate->push_new<structop_operation>
493 (pstate->pop (), copy_name ($3));
497 exp : exp '%' name COMPLETE
499 structop_base_operation *op
500 = new structop_operation (pstate->pop (),
502 pstate->mark_struct_expression (op);
503 pstate->push (operation_up (op));
507 exp : exp '%' COMPLETE
509 structop_base_operation *op
510 = new structop_operation (pstate->pop (), "");
511 pstate->mark_struct_expression (op);
512 pstate->push (operation_up (op));
516 /* Binary operators in order of decreasing precedence. */
519 { pstate->wrap2<repeat_operation> (); }
522 exp : exp STARSTAR exp
523 { pstate->wrap2<exp_operation> (); }
527 { pstate->wrap2<mul_operation> (); }
531 { pstate->wrap2<div_operation> (); }
535 { pstate->wrap2<add_operation> (); }
539 { pstate->wrap2<sub_operation> (); }
543 { pstate->wrap2<lsh_operation> (); }
547 { pstate->wrap2<rsh_operation> (); }
551 { pstate->wrap2<equal_operation> (); }
554 exp : exp NOTEQUAL exp
555 { pstate->wrap2<notequal_operation> (); }
559 { pstate->wrap2<leq_operation> (); }
563 { pstate->wrap2<geq_operation> (); }
566 exp : exp LESSTHAN exp
567 { pstate->wrap2<less_operation> (); }
570 exp : exp GREATERTHAN exp
571 { pstate->wrap2<gtr_operation> (); }
575 { pstate->wrap2<bitwise_and_operation> (); }
579 { pstate->wrap2<bitwise_xor_operation> (); }
583 { pstate->wrap2<bitwise_ior_operation> (); }
586 exp : exp BOOL_AND exp
587 { pstate->wrap2<logical_and_operation> (); }
591 exp : exp BOOL_OR exp
592 { pstate->wrap2<logical_or_operation> (); }
596 { pstate->wrap2<assign_operation> (); }
599 exp : exp ASSIGN_MODIFY exp
601 operation_up rhs = pstate->pop ();
602 operation_up lhs = pstate->pop ();
603 pstate->push_new<assign_modify_operation>
604 ($2, std::move (lhs), std::move (rhs));
610 pstate->push_new<long_const_operation>
617 parse_number (pstate, $1.stoken.ptr,
618 $1.stoken.length, 0, &val);
619 pstate->push_new<long_const_operation>
628 std::copy (std::begin ($1.val), std::end ($1.val),
630 pstate->push_new<float_const_operation> ($1.type, data);
637 exp : DOLLAR_VARIABLE
638 { pstate->push_dollar ($1); }
641 exp : SIZEOF '(' type ')' %prec UNARY
643 $3 = check_typedef ($3);
644 pstate->push_new<long_const_operation>
645 (parse_f_type (pstate)->builtin_integer,
650 exp : BOOLEAN_LITERAL
651 { pstate->push_new<bool_operation> ($1); }
656 pstate->push_new<string_operation>
661 variable: name_not_typename
662 { struct block_symbol sym = $1.sym;
663 std::string name = copy_name ($1.stoken);
664 pstate->push_symbol (name.c_str (), sym);
675 /* This is where the interesting stuff happens. */
678 struct type *follow_type = $1;
679 struct type *range_type;
682 switch (type_stack->pop ())
688 follow_type = lookup_pointer_type (follow_type);
691 follow_type = lookup_lvalue_reference_type (follow_type);
694 array_size = type_stack->pop_int ();
695 if (array_size != -1)
698 create_static_range_type ((struct type *) NULL,
699 parse_f_type (pstate)
703 create_array_type ((struct type *) NULL,
704 follow_type, range_type);
707 follow_type = lookup_pointer_type (follow_type);
710 follow_type = lookup_function_type (follow_type);
714 int kind_val = type_stack->pop_int ();
716 = convert_to_kind_type (follow_type, kind_val);
725 { type_stack->push (tp_pointer); $$ = 0; }
727 { type_stack->push (tp_pointer); $$ = $2; }
729 { type_stack->push (tp_reference); $$ = 0; }
731 { type_stack->push (tp_reference); $$ = $2; }
735 direct_abs_decl: '(' abs_decl ')'
737 | '(' KIND '=' INT ')'
738 { push_kind_type ($4.val, $4.type); }
740 { push_kind_type ($2.val, $2.type); }
741 | direct_abs_decl func_mod
742 { type_stack->push (tp_function); }
744 { type_stack->push (tp_function); }
749 | '(' nonempty_typelist ')'
750 { free ($2); $$ = 0; }
753 typebase /* Implements (approximately): (type-qualifier)* type-specifier */
757 { $$ = parse_f_type (pstate)->builtin_integer; }
759 { $$ = parse_f_type (pstate)->builtin_integer_s2; }
761 { $$ = parse_f_type (pstate)->builtin_character; }
763 { $$ = parse_f_type (pstate)->builtin_logical_s8; }
765 { $$ = parse_f_type (pstate)->builtin_logical; }
767 { $$ = parse_f_type (pstate)->builtin_logical_s2; }
769 { $$ = parse_f_type (pstate)->builtin_logical_s1; }
771 { $$ = parse_f_type (pstate)->builtin_real; }
773 { $$ = parse_f_type (pstate)->builtin_real_s8; }
775 { $$ = parse_f_type (pstate)->builtin_real_s16; }
777 { $$ = parse_f_type (pstate)->builtin_complex_s8; }
779 { $$ = parse_f_type (pstate)->builtin_complex_s8; }
780 | COMPLEX_S16_KEYWORD
781 { $$ = parse_f_type (pstate)->builtin_complex_s16; }
782 | COMPLEX_S32_KEYWORD
783 { $$ = parse_f_type (pstate)->builtin_complex_s32; }
785 { $$ = parse_f_type (pstate)->builtin_real;}
787 { $$ = parse_f_type (pstate)->builtin_real_s8;}
788 | SINGLE COMPLEX_KEYWORD
789 { $$ = parse_f_type (pstate)->builtin_complex_s8;}
790 | DOUBLE COMPLEX_KEYWORD
791 { $$ = parse_f_type (pstate)->builtin_complex_s16;}
796 { $$ = (struct type **) malloc (sizeof (struct type *) * 2);
797 $<ivec>$[0] = 1; /* Number of types in vector */
800 | nonempty_typelist ',' type
801 { int len = sizeof (struct type *) * (++($<ivec>1[0]) + 1);
802 $$ = (struct type **) realloc ((char *) $1, len);
803 $$[$<ivec>$[0]] = $3;
811 name_not_typename : NAME
812 /* These would be useful if name_not_typename was useful, but it is just
813 a fake for "variable", so these cause reduce/reduce conflicts because
814 the parser can't tell whether NAME_OR_INT is a name_not_typename (=variable,
815 =exp) or just an exp. If name_not_typename was ever used in an lvalue
816 context where only a name could occur, this might be useful.
823 /* Take care of parsing a number (anything that starts with a digit).
824 Set yylval and return the token type; update lexptr.
825 LEN is the number of characters in it. */
827 /*** Needs some error checking for the float case ***/
830 parse_number (struct parser_state *par_state,
831 const char *p, int len, int parsed_float, YYSTYPE *putithere)
836 int base = input_radix;
840 struct type *signed_type;
841 struct type *unsigned_type;
845 /* It's a float since it contains a point or an exponent. */
846 /* [dD] is not understood as an exponent by parse_float,
851 for (tmp2 = tmp; *tmp2; ++tmp2)
852 if (*tmp2 == 'd' || *tmp2 == 'D')
855 /* FIXME: Should this use different types? */
856 putithere->typed_val_float.type = parse_f_type (pstate)->builtin_real_s8;
857 bool parsed = parse_float (tmp, len,
858 putithere->typed_val_float.type,
859 putithere->typed_val_float.val);
861 return parsed? FLOAT : ERROR;
864 /* Handle base-switching prefixes 0x, 0t, 0d, 0 */
900 if (len == 0 && c == 'l')
902 else if (len == 0 && c == 'u')
907 if (c >= '0' && c <= '9')
909 else if (c >= 'a' && c <= 'f')
912 return ERROR; /* Char not a digit */
914 return ERROR; /* Invalid digit in this base */
918 /* Portably test for overflow (only works for nonzero values, so make
919 a second check for zero). */
920 if ((prevn >= n) && n != 0)
921 unsigned_p=1; /* Try something unsigned */
922 /* If range checking enabled, portably test for unsigned overflow. */
923 if (RANGE_CHECK && n != 0)
925 if ((unsigned_p && (unsigned)prevn >= (unsigned)n))
926 range_error (_("Overflow on numeric constant."));
931 /* If the number is too big to be an int, or it's got an l suffix
932 then it's a long. Work out if this has to be a long by
933 shifting right and seeing if anything remains, and the
934 target int size is different to the target long size.
936 In the expression below, we could have tested
937 (n >> gdbarch_int_bit (parse_gdbarch))
938 to see if it was zero,
939 but too many compilers warn about that, when ints and longs
940 are the same size. So we shift it twice, with fewer bits
941 each time, for the same result. */
943 if ((gdbarch_int_bit (par_state->gdbarch ())
944 != gdbarch_long_bit (par_state->gdbarch ())
946 >> (gdbarch_int_bit (par_state->gdbarch ())-2))) /* Avoid
950 high_bit = ((ULONGEST)1)
951 << (gdbarch_long_bit (par_state->gdbarch ())-1);
952 unsigned_type = parse_type (par_state)->builtin_unsigned_long;
953 signed_type = parse_type (par_state)->builtin_long;
958 ((ULONGEST)1) << (gdbarch_int_bit (par_state->gdbarch ()) - 1);
959 unsigned_type = parse_type (par_state)->builtin_unsigned_int;
960 signed_type = parse_type (par_state)->builtin_int;
963 putithere->typed_val.val = n;
965 /* If the high bit of the worked out type is set then this number
966 has to be unsigned. */
968 if (unsigned_p || (n & high_bit))
969 putithere->typed_val.type = unsigned_type;
971 putithere->typed_val.type = signed_type;
976 /* Called to setup the type stack when we encounter a '(kind=N)' type
977 modifier, performs some bounds checking on 'N' and then pushes this to
978 the type stack followed by the 'tp_kind' marker. */
980 push_kind_type (LONGEST val, struct type *type)
984 if (type->is_unsigned ())
986 ULONGEST uval = static_cast <ULONGEST> (val);
988 error (_("kind value out of range"));
989 ival = static_cast <int> (uval);
993 if (val > INT_MAX || val < 0)
994 error (_("kind value out of range"));
995 ival = static_cast <int> (val);
998 type_stack->push (ival);
999 type_stack->push (tp_kind);
1002 /* Called when a type has a '(kind=N)' modifier after it, for example
1003 'character(kind=1)'. The BASETYPE is the type described by 'character'
1004 in our example, and KIND is the integer '1'. This function returns a
1005 new type that represents the basetype of a specific kind. */
1006 static struct type *
1007 convert_to_kind_type (struct type *basetype, int kind)
1009 if (basetype == parse_f_type (pstate)->builtin_character)
1011 /* Character of kind 1 is a special case, this is the same as the
1012 base character type. */
1014 return parse_f_type (pstate)->builtin_character;
1016 else if (basetype == parse_f_type (pstate)->builtin_complex_s8)
1019 return parse_f_type (pstate)->builtin_complex_s8;
1021 return parse_f_type (pstate)->builtin_complex_s16;
1022 else if (kind == 16)
1023 return parse_f_type (pstate)->builtin_complex_s32;
1025 else if (basetype == parse_f_type (pstate)->builtin_real)
1028 return parse_f_type (pstate)->builtin_real;
1030 return parse_f_type (pstate)->builtin_real_s8;
1031 else if (kind == 16)
1032 return parse_f_type (pstate)->builtin_real_s16;
1034 else if (basetype == parse_f_type (pstate)->builtin_logical)
1037 return parse_f_type (pstate)->builtin_logical_s1;
1039 return parse_f_type (pstate)->builtin_logical_s2;
1041 return parse_f_type (pstate)->builtin_logical;
1043 return parse_f_type (pstate)->builtin_logical_s8;
1045 else if (basetype == parse_f_type (pstate)->builtin_integer)
1048 return parse_f_type (pstate)->builtin_integer_s2;
1050 return parse_f_type (pstate)->builtin_integer;
1052 return parse_f_type (pstate)->builtin_integer_s8;
1055 error (_("unsupported kind %d for type %s"),
1056 kind, TYPE_SAFE_NAME (basetype));
1058 /* Should never get here. */
1064 /* The string to match against. */
1067 /* The lexer token to return. */
1070 /* The expression opcode to embed within the token. */
1071 enum exp_opcode opcode;
1073 /* When this is true the string in OPER is matched exactly including
1074 case, when this is false OPER is matched case insensitively. */
1075 bool case_sensitive;
1078 /* List of Fortran operators. */
1080 static const struct token fortran_operators[] =
1082 { ".and.", BOOL_AND, OP_NULL, false },
1083 { ".or.", BOOL_OR, OP_NULL, false },
1084 { ".not.", BOOL_NOT, OP_NULL, false },
1085 { ".eq.", EQUAL, OP_NULL, false },
1086 { ".eqv.", EQUAL, OP_NULL, false },
1087 { ".neqv.", NOTEQUAL, OP_NULL, false },
1088 { ".xor.", NOTEQUAL, OP_NULL, false },
1089 { "==", EQUAL, OP_NULL, false },
1090 { ".ne.", NOTEQUAL, OP_NULL, false },
1091 { "/=", NOTEQUAL, OP_NULL, false },
1092 { ".le.", LEQ, OP_NULL, false },
1093 { "<=", LEQ, OP_NULL, false },
1094 { ".ge.", GEQ, OP_NULL, false },
1095 { ">=", GEQ, OP_NULL, false },
1096 { ".gt.", GREATERTHAN, OP_NULL, false },
1097 { ">", GREATERTHAN, OP_NULL, false },
1098 { ".lt.", LESSTHAN, OP_NULL, false },
1099 { "<", LESSTHAN, OP_NULL, false },
1100 { "**", STARSTAR, BINOP_EXP, false },
1103 /* Holds the Fortran representation of a boolean, and the integer value we
1104 substitute in when one of the matching strings is parsed. */
1105 struct f77_boolean_val
1107 /* The string representing a Fortran boolean. */
1110 /* The integer value to replace it with. */
1114 /* The set of Fortran booleans. These are matched case insensitively. */
1115 static const struct f77_boolean_val boolean_values[] =
1121 static const struct token f77_keywords[] =
1123 /* Historically these have always been lowercase only in GDB. */
1124 { "complex_16", COMPLEX_S16_KEYWORD, OP_NULL, true },
1125 { "complex_32", COMPLEX_S32_KEYWORD, OP_NULL, true },
1126 { "character", CHARACTER, OP_NULL, true },
1127 { "integer_2", INT_S2_KEYWORD, OP_NULL, true },
1128 { "logical_1", LOGICAL_S1_KEYWORD, OP_NULL, true },
1129 { "logical_2", LOGICAL_S2_KEYWORD, OP_NULL, true },
1130 { "logical_8", LOGICAL_S8_KEYWORD, OP_NULL, true },
1131 { "complex_8", COMPLEX_S8_KEYWORD, OP_NULL, true },
1132 { "integer", INT_KEYWORD, OP_NULL, true },
1133 { "logical", LOGICAL_KEYWORD, OP_NULL, true },
1134 { "real_16", REAL_S16_KEYWORD, OP_NULL, true },
1135 { "complex", COMPLEX_KEYWORD, OP_NULL, true },
1136 { "sizeof", SIZEOF, OP_NULL, true },
1137 { "real_8", REAL_S8_KEYWORD, OP_NULL, true },
1138 { "real", REAL_KEYWORD, OP_NULL, true },
1139 { "single", SINGLE, OP_NULL, true },
1140 { "double", DOUBLE, OP_NULL, true },
1141 { "precision", PRECISION, OP_NULL, true },
1142 /* The following correspond to actual functions in Fortran and are case
1144 { "kind", KIND, OP_NULL, false },
1145 { "abs", UNOP_INTRINSIC, UNOP_ABS, false },
1146 { "mod", BINOP_INTRINSIC, BINOP_MOD, false },
1147 { "floor", UNOP_INTRINSIC, UNOP_FORTRAN_FLOOR, false },
1148 { "ceiling", UNOP_INTRINSIC, UNOP_FORTRAN_CEILING, false },
1149 { "modulo", BINOP_INTRINSIC, BINOP_FORTRAN_MODULO, false },
1150 { "cmplx", BINOP_INTRINSIC, BINOP_FORTRAN_CMPLX, false },
1151 { "lbound", UNOP_OR_BINOP_INTRINSIC, FORTRAN_LBOUND, false },
1152 { "ubound", UNOP_OR_BINOP_INTRINSIC, FORTRAN_UBOUND, false },
1153 { "allocated", UNOP_INTRINSIC, UNOP_FORTRAN_ALLOCATED, false },
1154 { "associated", UNOP_OR_BINOP_INTRINSIC, FORTRAN_ASSOCIATED, false },
1155 { "rank", UNOP_INTRINSIC, UNOP_FORTRAN_RANK, false },
1156 { "size", UNOP_OR_BINOP_INTRINSIC, FORTRAN_ARRAY_SIZE, false },
1157 { "shape", UNOP_INTRINSIC, UNOP_FORTRAN_SHAPE, false },
1160 /* Implementation of a dynamically expandable buffer for processing input
1161 characters acquired through lexptr and building a value to return in
1162 yylval. Ripped off from ch-exp.y */
1164 static char *tempbuf; /* Current buffer contents */
1165 static int tempbufsize; /* Size of allocated buffer */
1166 static int tempbufindex; /* Current index into buffer */
1168 #define GROWBY_MIN_SIZE 64 /* Minimum amount to grow buffer by */
1170 #define CHECKBUF(size) \
1172 if (tempbufindex + (size) >= tempbufsize) \
1174 growbuf_by_size (size); \
1179 /* Grow the static temp buffer if necessary, including allocating the
1180 first one on demand. */
1183 growbuf_by_size (int count)
1187 growby = std::max (count, GROWBY_MIN_SIZE);
1188 tempbufsize += growby;
1189 if (tempbuf == NULL)
1190 tempbuf = (char *) malloc (tempbufsize);
1192 tempbuf = (char *) realloc (tempbuf, tempbufsize);
1195 /* Blatantly ripped off from ch-exp.y. This routine recognizes F77
1198 Recognize a string literal. A string literal is a nonzero sequence
1199 of characters enclosed in matching single quotes, except that
1200 a single character inside single quotes is a character literal, which
1201 we reject as a string literal. To embed the terminator character inside
1202 a string, it is simply doubled (I.E. 'this''is''one''string') */
1205 match_string_literal (void)
1207 const char *tokptr = pstate->lexptr;
1209 for (tempbufindex = 0, tokptr++; *tokptr != '\0'; tokptr++)
1212 if (*tokptr == *pstate->lexptr)
1214 if (*(tokptr + 1) == *pstate->lexptr)
1219 tempbuf[tempbufindex++] = *tokptr;
1221 if (*tokptr == '\0' /* no terminator */
1222 || tempbufindex == 0) /* no string */
1226 tempbuf[tempbufindex] = '\0';
1227 yylval.sval.ptr = tempbuf;
1228 yylval.sval.length = tempbufindex;
1229 pstate->lexptr = ++tokptr;
1230 return STRING_LITERAL;
1234 /* This is set if a NAME token appeared at the very end of the input
1235 string, with no whitespace separating the name from the EOF. This
1236 is used only when parsing to do field name completion. */
1237 static bool saw_name_at_eof;
1239 /* This is set if the previously-returned token was a structure
1241 static bool last_was_structop;
1243 /* Read one token, getting characters through lexptr. */
1251 const char *tokstart;
1252 bool saw_structop = last_was_structop;
1254 last_was_structop = false;
1258 pstate->prev_lexptr = pstate->lexptr;
1260 tokstart = pstate->lexptr;
1262 /* First of all, let us make sure we are not dealing with the
1263 special tokens .true. and .false. which evaluate to 1 and 0. */
1265 if (*pstate->lexptr == '.')
1267 for (int i = 0; i < ARRAY_SIZE (boolean_values); i++)
1269 if (strncasecmp (tokstart, boolean_values[i].name,
1270 strlen (boolean_values[i].name)) == 0)
1272 pstate->lexptr += strlen (boolean_values[i].name);
1273 yylval.lval = boolean_values[i].value;
1274 return BOOLEAN_LITERAL;
1279 /* See if it is a Fortran operator. */
1280 for (int i = 0; i < ARRAY_SIZE (fortran_operators); i++)
1281 if (strncasecmp (tokstart, fortran_operators[i].oper,
1282 strlen (fortran_operators[i].oper)) == 0)
1284 gdb_assert (!fortran_operators[i].case_sensitive);
1285 pstate->lexptr += strlen (fortran_operators[i].oper);
1286 yylval.opcode = fortran_operators[i].opcode;
1287 return fortran_operators[i].token;
1290 switch (c = *tokstart)
1293 if (saw_name_at_eof)
1295 saw_name_at_eof = false;
1298 else if (pstate->parse_completion && saw_structop)
1309 token = match_string_literal ();
1320 if (paren_depth == 0)
1327 if (pstate->comma_terminates && paren_depth == 0)
1333 /* Might be a floating point number. */
1334 if (pstate->lexptr[1] < '0' || pstate->lexptr[1] > '9')
1335 goto symbol; /* Nope, must be a symbol. */
1349 /* It's a number. */
1350 int got_dot = 0, got_e = 0, got_d = 0, toktype;
1351 const char *p = tokstart;
1352 int hex = input_radix > 10;
1354 if (c == '0' && (p[1] == 'x' || p[1] == 'X'))
1359 else if (c == '0' && (p[1]=='t' || p[1]=='T'
1360 || p[1]=='d' || p[1]=='D'))
1368 if (!hex && !got_e && (*p == 'e' || *p == 'E'))
1369 got_dot = got_e = 1;
1370 else if (!hex && !got_d && (*p == 'd' || *p == 'D'))
1371 got_dot = got_d = 1;
1372 else if (!hex && !got_dot && *p == '.')
1374 else if (((got_e && (p[-1] == 'e' || p[-1] == 'E'))
1375 || (got_d && (p[-1] == 'd' || p[-1] == 'D')))
1376 && (*p == '-' || *p == '+'))
1377 /* This is the sign of the exponent, not the end of the
1380 /* We will take any letters or digits. parse_number will
1381 complain if past the radix, or if L or U are not final. */
1382 else if ((*p < '0' || *p > '9')
1383 && ((*p < 'a' || *p > 'z')
1384 && (*p < 'A' || *p > 'Z')))
1387 toktype = parse_number (pstate, tokstart, p - tokstart,
1388 got_dot|got_e|got_d,
1390 if (toktype == ERROR)
1392 char *err_copy = (char *) alloca (p - tokstart + 1);
1394 memcpy (err_copy, tokstart, p - tokstart);
1395 err_copy[p - tokstart] = 0;
1396 error (_("Invalid number \"%s\"."), err_copy);
1403 last_was_structop = true;
1429 if (!(c == '_' || c == '$' || c ==':'
1430 || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')))
1431 /* We must have come across a bad character (e.g. ';'). */
1432 error (_("Invalid character '%c' in expression."), c);
1435 for (c = tokstart[namelen];
1436 (c == '_' || c == '$' || c == ':' || (c >= '0' && c <= '9')
1437 || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'));
1438 c = tokstart[++namelen]);
1440 /* The token "if" terminates the expression and is NOT
1441 removed from the input stream. */
1443 if (namelen == 2 && tokstart[0] == 'i' && tokstart[1] == 'f')
1446 pstate->lexptr += namelen;
1448 /* Catch specific keywords. */
1450 for (int i = 0; i < ARRAY_SIZE (f77_keywords); i++)
1451 if (strlen (f77_keywords[i].oper) == namelen
1452 && ((!f77_keywords[i].case_sensitive
1453 && strncasecmp (tokstart, f77_keywords[i].oper, namelen) == 0)
1454 || (f77_keywords[i].case_sensitive
1455 && strncmp (tokstart, f77_keywords[i].oper, namelen) == 0)))
1457 yylval.opcode = f77_keywords[i].opcode;
1458 return f77_keywords[i].token;
1461 yylval.sval.ptr = tokstart;
1462 yylval.sval.length = namelen;
1464 if (*tokstart == '$')
1465 return DOLLAR_VARIABLE;
1467 /* Use token-type TYPENAME for symbols that happen to be defined
1468 currently as names of types; NAME for other symbols.
1469 The caller is not constrained to care about the distinction. */
1471 std::string tmp = copy_name (yylval.sval);
1472 struct block_symbol result;
1473 enum domain_enum_tag lookup_domains[] =
1481 for (int i = 0; i < ARRAY_SIZE (lookup_domains); ++i)
1483 result = lookup_symbol (tmp.c_str (), pstate->expression_context_block,
1484 lookup_domains[i], NULL);
1485 if (result.symbol && SYMBOL_CLASS (result.symbol) == LOC_TYPEDEF)
1487 yylval.tsym.type = SYMBOL_TYPE (result.symbol);
1496 = language_lookup_primitive_type (pstate->language (),
1497 pstate->gdbarch (), tmp.c_str ());
1498 if (yylval.tsym.type != NULL)
1501 /* Input names that aren't symbols but ARE valid hex numbers,
1502 when the input radix permits them, can be names or numbers
1503 depending on the parse. Note we support radixes > 16 here. */
1505 && ((tokstart[0] >= 'a' && tokstart[0] < 'a' + input_radix - 10)
1506 || (tokstart[0] >= 'A' && tokstart[0] < 'A' + input_radix - 10)))
1508 YYSTYPE newlval; /* Its value is ignored. */
1509 hextype = parse_number (pstate, tokstart, namelen, 0, &newlval);
1512 yylval.ssym.sym = result;
1513 yylval.ssym.is_a_field_of_this = false;
1518 if (pstate->parse_completion && *pstate->lexptr == '\0')
1519 saw_name_at_eof = true;
1521 /* Any other kind of symbol */
1522 yylval.ssym.sym = result;
1523 yylval.ssym.is_a_field_of_this = false;
1529 f_language::parser (struct parser_state *par_state) const
1531 /* Setting up the parser state. */
1532 scoped_restore pstate_restore = make_scoped_restore (&pstate);
1533 scoped_restore restore_yydebug = make_scoped_restore (&yydebug,
1535 gdb_assert (par_state != NULL);
1537 last_was_structop = false;
1538 saw_name_at_eof = false;
1541 struct type_stack stack;
1542 scoped_restore restore_type_stack = make_scoped_restore (&type_stack,
1545 int result = yyparse ();
1547 pstate->set_operation (pstate->pop ());
1552 yyerror (const char *msg)
1554 if (pstate->prev_lexptr)
1555 pstate->lexptr = pstate->prev_lexptr;
1557 error (_("A %s in expression, near `%s'."), msg, pstate->lexptr);