2 /* YACC parser for Fortran expressions, for GDB.
3 Copyright (C) 1986-2021 Free Software Foundation, Inc.
5 Contributed by Motorola. Adapted from the C parser by Farooq Butt
6 (fmbutt@engage.sps.mot.com).
8 This file is part of GDB.
10 This program is free software; you can redistribute it and/or modify
11 it under the terms of the GNU General Public License as published by
12 the Free Software Foundation; either version 3 of the License, or
13 (at your option) any later version.
15 This program is distributed in the hope that it will be useful,
16 but WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 GNU General Public License for more details.
20 You should have received a copy of the GNU General Public License
21 along with this program. If not, see <http://www.gnu.org/licenses/>. */
23 /* This was blantantly ripped off the C expression parser, please
24 be aware of that as you look at its basic structure -FMB */
26 /* Parse a F77 expression from text in a string,
27 and return the result as a struct expression pointer.
28 That structure contains arithmetic operations in reverse polish,
29 with constants represented by operations that are followed by special data.
30 See expression.h for the details of the format.
31 What is important here is that it can be built up sequentially
32 during the process of parsing; the lower levels of the tree always
33 come first in the result.
35 Note that malloc's and realloc's in this file are transformed to
36 xmalloc and xrealloc respectively by the same sed command in the
37 makefile that remaps any other malloc/realloc inserted by the parser
38 generator. Doing this with #defines and trying to control the interaction
39 with include files (<malloc.h> and <stdlib.h> for example) just became
40 too messy, particularly when such includes can be inserted at random
41 times by the parser generator. */
46 #include "expression.h"
48 #include "parser-defs.h"
51 #include "bfd.h" /* Required by objfiles.h. */
52 #include "symfile.h" /* Required by objfiles.h. */
53 #include "objfiles.h" /* For have_full_symbols and have_partial_symbols */
57 #include "type-stack.h"
60 #define parse_type(ps) builtin_type (ps->gdbarch ())
61 #define parse_f_type(ps) builtin_f_type (ps->gdbarch ())
63 /* Remap normal yacc parser interface names (yyparse, yylex, yyerror,
65 #define GDB_YY_REMAP_PREFIX f_
68 /* The state of the parser, used internally when we are parsing the
71 static struct parser_state *pstate = NULL;
73 /* Depth of parentheses. */
74 static int paren_depth;
76 /* The current type stack. */
77 static struct type_stack *type_stack;
81 static int yylex (void);
83 static void yyerror (const char *);
85 static void growbuf_by_size (int);
87 static int match_string_literal (void);
89 static void push_kind_type (LONGEST val, struct type *type);
91 static struct type *convert_to_kind_type (struct type *basetype, int kind);
96 /* Although the yacc "value" of an expression is not used,
97 since the result is stored in the structure being created,
98 other node types do have values. */
115 struct symtoken ssym;
117 enum exp_opcode opcode;
118 struct internalvar *ivar;
125 /* YYSTYPE gets defined by %union */
126 static int parse_number (struct parser_state *, const char *, int,
130 %type <voidval> exp type_exp start variable
131 %type <tval> type typebase
132 %type <tvec> nonempty_typelist
133 /* %type <bval> block */
135 /* Fancy type parsing. */
136 %type <voidval> func_mod direct_abs_decl abs_decl
139 %token <typed_val> INT
140 %token <typed_val_float> FLOAT
142 /* Both NAME and TYPENAME tokens represent symbols in the input,
143 and both convey their data as strings.
144 But a TYPENAME is a string that happens to be defined as a typedef
145 or builtin type name (such as int or char)
146 and a NAME is any other symbol.
147 Contexts where this distinction is not important can use the
148 nonterminal "name", which matches either NAME or TYPENAME. */
150 %token <sval> STRING_LITERAL
151 %token <lval> BOOLEAN_LITERAL
153 %token <tsym> TYPENAME
154 %token <voidval> COMPLETE
156 %type <ssym> name_not_typename
158 /* A NAME_OR_INT is a symbol which is not known in the symbol table,
159 but which would parse as a valid number in the current input radix.
160 E.g. "c" when input_radix==16. Depending on the parse, it will be
161 turned into a name or into a number. */
163 %token <ssym> NAME_OR_INT
168 /* Special type cases, put in to allow the parser to distinguish different
170 %token INT_KEYWORD INT_S2_KEYWORD LOGICAL_S1_KEYWORD LOGICAL_S2_KEYWORD
171 %token LOGICAL_S8_KEYWORD
172 %token LOGICAL_KEYWORD REAL_KEYWORD REAL_S8_KEYWORD REAL_S16_KEYWORD
173 %token COMPLEX_KEYWORD
174 %token COMPLEX_S8_KEYWORD COMPLEX_S16_KEYWORD COMPLEX_S32_KEYWORD
175 %token BOOL_AND BOOL_OR BOOL_NOT
176 %token SINGLE DOUBLE PRECISION
177 %token <lval> CHARACTER
179 %token <sval> DOLLAR_VARIABLE
181 %token <opcode> ASSIGN_MODIFY
182 %token <opcode> UNOP_INTRINSIC BINOP_INTRINSIC
183 %token <opcode> UNOP_OR_BINOP_INTRINSIC
187 %right '=' ASSIGN_MODIFY
196 %left LESSTHAN GREATERTHAN LEQ GEQ
214 { pstate->push_new<type_operation> ($1); }
221 /* Expressions, not including the comma operator. */
222 exp : '*' exp %prec UNARY
223 { pstate->wrap<unop_ind_operation> (); }
226 exp : '&' exp %prec UNARY
227 { pstate->wrap<unop_addr_operation> (); }
230 exp : '-' exp %prec UNARY
231 { pstate->wrap<unary_neg_operation> (); }
234 exp : BOOL_NOT exp %prec UNARY
235 { pstate->wrap<unary_logical_not_operation> (); }
238 exp : '~' exp %prec UNARY
239 { pstate->wrap<unary_complement_operation> (); }
242 exp : SIZEOF exp %prec UNARY
243 { pstate->wrap<unop_sizeof_operation> (); }
246 exp : KIND '(' exp ')' %prec UNARY
247 { pstate->wrap<fortran_kind_operation> (); }
250 exp : UNOP_OR_BINOP_INTRINSIC '('
251 { pstate->start_arglist (); }
254 int n = pstate->end_arglist ();
255 gdb_assert (n == 1 || n == 2);
256 if ($1 == FORTRAN_ASSOCIATED)
259 pstate->wrap<fortran_associated_1arg> ();
261 pstate->wrap2<fortran_associated_2arg> ();
265 std::vector<operation_up> args
266 = pstate->pop_vector (n);
267 gdb_assert ($1 == FORTRAN_LBOUND
268 || $1 == FORTRAN_UBOUND);
272 (new fortran_bound_1arg ($1,
273 std::move (args[0])));
276 (new fortran_bound_2arg ($1,
278 std::move (args[1])));
279 pstate->push (std::move (op));
286 { pstate->arglist_len = 1; }
288 { pstate->arglist_len = 2; }
291 /* No more explicit array operators, we treat everything in F77 as
292 a function call. The disambiguation as to whether we are
293 doing a subscript operation or a function call is done
297 { pstate->start_arglist (); }
300 std::vector<operation_up> args
301 = pstate->pop_vector (pstate->end_arglist ());
302 pstate->push_new<fortran_undetermined>
303 (pstate->pop (), std::move (args));
307 exp : UNOP_INTRINSIC '(' exp ')'
312 pstate->wrap<fortran_abs_operation> ();
314 case UNOP_FORTRAN_FLOOR:
315 pstate->wrap<fortran_floor_operation> ();
317 case UNOP_FORTRAN_CEILING:
318 pstate->wrap<fortran_ceil_operation> ();
320 case UNOP_FORTRAN_ALLOCATED:
321 pstate->wrap<fortran_allocated_operation> ();
324 gdb_assert_not_reached ("unhandled intrinsic");
329 exp : BINOP_INTRINSIC '(' exp ',' exp ')'
334 pstate->wrap2<fortran_mod_operation> ();
336 case BINOP_FORTRAN_MODULO:
337 pstate->wrap2<fortran_modulo_operation> ();
339 case BINOP_FORTRAN_CMPLX:
340 pstate->wrap2<fortran_cmplx_operation> ();
343 gdb_assert_not_reached ("unhandled intrinsic");
352 { pstate->arglist_len = 1; }
356 { pstate->arglist_len = 1; }
359 arglist : arglist ',' exp %prec ABOVE_COMMA
360 { pstate->arglist_len++; }
363 arglist : arglist ',' subrange %prec ABOVE_COMMA
364 { pstate->arglist_len++; }
367 /* There are four sorts of subrange types in F90. */
369 subrange: exp ':' exp %prec ABOVE_COMMA
371 operation_up high = pstate->pop ();
372 operation_up low = pstate->pop ();
373 pstate->push_new<fortran_range_operation>
374 (RANGE_STANDARD, std::move (low),
375 std::move (high), operation_up ());
379 subrange: exp ':' %prec ABOVE_COMMA
381 operation_up low = pstate->pop ();
382 pstate->push_new<fortran_range_operation>
383 (RANGE_HIGH_BOUND_DEFAULT, std::move (low),
384 operation_up (), operation_up ());
388 subrange: ':' exp %prec ABOVE_COMMA
390 operation_up high = pstate->pop ();
391 pstate->push_new<fortran_range_operation>
392 (RANGE_LOW_BOUND_DEFAULT, operation_up (),
393 std::move (high), operation_up ());
397 subrange: ':' %prec ABOVE_COMMA
399 pstate->push_new<fortran_range_operation>
400 (RANGE_LOW_BOUND_DEFAULT
401 | RANGE_HIGH_BOUND_DEFAULT,
402 operation_up (), operation_up (),
407 /* And each of the four subrange types can also have a stride. */
408 subrange: exp ':' exp ':' exp %prec ABOVE_COMMA
410 operation_up stride = pstate->pop ();
411 operation_up high = pstate->pop ();
412 operation_up low = pstate->pop ();
413 pstate->push_new<fortran_range_operation>
414 (RANGE_STANDARD | RANGE_HAS_STRIDE,
415 std::move (low), std::move (high),
420 subrange: exp ':' ':' exp %prec ABOVE_COMMA
422 operation_up stride = pstate->pop ();
423 operation_up low = pstate->pop ();
424 pstate->push_new<fortran_range_operation>
425 (RANGE_HIGH_BOUND_DEFAULT
427 std::move (low), operation_up (),
432 subrange: ':' exp ':' exp %prec ABOVE_COMMA
434 operation_up stride = pstate->pop ();
435 operation_up high = pstate->pop ();
436 pstate->push_new<fortran_range_operation>
437 (RANGE_LOW_BOUND_DEFAULT
439 operation_up (), std::move (high),
444 subrange: ':' ':' exp %prec ABOVE_COMMA
446 operation_up stride = pstate->pop ();
447 pstate->push_new<fortran_range_operation>
448 (RANGE_LOW_BOUND_DEFAULT
449 | RANGE_HIGH_BOUND_DEFAULT
451 operation_up (), operation_up (),
456 complexnum: exp ',' exp
460 exp : '(' complexnum ')'
462 operation_up rhs = pstate->pop ();
463 operation_up lhs = pstate->pop ();
464 pstate->push_new<complex_operation>
465 (std::move (lhs), std::move (rhs),
466 parse_f_type (pstate)->builtin_complex_s16);
470 exp : '(' type ')' exp %prec UNARY
472 pstate->push_new<unop_cast_operation>
473 (pstate->pop (), $2);
479 pstate->push_new<structop_operation>
480 (pstate->pop (), copy_name ($3));
484 exp : exp '%' name COMPLETE
486 structop_base_operation *op
487 = new structop_operation (pstate->pop (),
489 pstate->mark_struct_expression (op);
490 pstate->push (operation_up (op));
494 exp : exp '%' COMPLETE
496 structop_base_operation *op
497 = new structop_operation (pstate->pop (), "");
498 pstate->mark_struct_expression (op);
499 pstate->push (operation_up (op));
503 /* Binary operators in order of decreasing precedence. */
506 { pstate->wrap2<repeat_operation> (); }
509 exp : exp STARSTAR exp
510 { pstate->wrap2<exp_operation> (); }
514 { pstate->wrap2<mul_operation> (); }
518 { pstate->wrap2<div_operation> (); }
522 { pstate->wrap2<add_operation> (); }
526 { pstate->wrap2<sub_operation> (); }
530 { pstate->wrap2<lsh_operation> (); }
534 { pstate->wrap2<rsh_operation> (); }
538 { pstate->wrap2<equal_operation> (); }
541 exp : exp NOTEQUAL exp
542 { pstate->wrap2<notequal_operation> (); }
546 { pstate->wrap2<leq_operation> (); }
550 { pstate->wrap2<geq_operation> (); }
553 exp : exp LESSTHAN exp
554 { pstate->wrap2<less_operation> (); }
557 exp : exp GREATERTHAN exp
558 { pstate->wrap2<gtr_operation> (); }
562 { pstate->wrap2<bitwise_and_operation> (); }
566 { pstate->wrap2<bitwise_xor_operation> (); }
570 { pstate->wrap2<bitwise_ior_operation> (); }
573 exp : exp BOOL_AND exp
574 { pstate->wrap2<logical_and_operation> (); }
578 exp : exp BOOL_OR exp
579 { pstate->wrap2<logical_or_operation> (); }
583 { pstate->wrap2<assign_operation> (); }
586 exp : exp ASSIGN_MODIFY exp
588 operation_up rhs = pstate->pop ();
589 operation_up lhs = pstate->pop ();
590 pstate->push_new<assign_modify_operation>
591 ($2, std::move (lhs), std::move (rhs));
597 pstate->push_new<long_const_operation>
604 parse_number (pstate, $1.stoken.ptr,
605 $1.stoken.length, 0, &val);
606 pstate->push_new<long_const_operation>
615 std::copy (std::begin ($1.val), std::end ($1.val),
617 pstate->push_new<float_const_operation> ($1.type, data);
624 exp : DOLLAR_VARIABLE
625 { pstate->push_dollar ($1); }
628 exp : SIZEOF '(' type ')' %prec UNARY
630 $3 = check_typedef ($3);
631 pstate->push_new<long_const_operation>
632 (parse_f_type (pstate)->builtin_integer,
637 exp : BOOLEAN_LITERAL
638 { pstate->push_new<bool_operation> ($1); }
643 pstate->push_new<string_operation>
648 variable: name_not_typename
649 { struct block_symbol sym = $1.sym;
650 std::string name = copy_name ($1.stoken);
651 pstate->push_symbol (name.c_str (), sym);
662 /* This is where the interesting stuff happens. */
665 struct type *follow_type = $1;
666 struct type *range_type;
669 switch (type_stack->pop ())
675 follow_type = lookup_pointer_type (follow_type);
678 follow_type = lookup_lvalue_reference_type (follow_type);
681 array_size = type_stack->pop_int ();
682 if (array_size != -1)
685 create_static_range_type ((struct type *) NULL,
686 parse_f_type (pstate)
690 create_array_type ((struct type *) NULL,
691 follow_type, range_type);
694 follow_type = lookup_pointer_type (follow_type);
697 follow_type = lookup_function_type (follow_type);
701 int kind_val = type_stack->pop_int ();
703 = convert_to_kind_type (follow_type, kind_val);
712 { type_stack->push (tp_pointer); $$ = 0; }
714 { type_stack->push (tp_pointer); $$ = $2; }
716 { type_stack->push (tp_reference); $$ = 0; }
718 { type_stack->push (tp_reference); $$ = $2; }
722 direct_abs_decl: '(' abs_decl ')'
724 | '(' KIND '=' INT ')'
725 { push_kind_type ($4.val, $4.type); }
727 { push_kind_type ($2.val, $2.type); }
728 | direct_abs_decl func_mod
729 { type_stack->push (tp_function); }
731 { type_stack->push (tp_function); }
736 | '(' nonempty_typelist ')'
737 { free ($2); $$ = 0; }
740 typebase /* Implements (approximately): (type-qualifier)* type-specifier */
744 { $$ = parse_f_type (pstate)->builtin_integer; }
746 { $$ = parse_f_type (pstate)->builtin_integer_s2; }
748 { $$ = parse_f_type (pstate)->builtin_character; }
750 { $$ = parse_f_type (pstate)->builtin_logical_s8; }
752 { $$ = parse_f_type (pstate)->builtin_logical; }
754 { $$ = parse_f_type (pstate)->builtin_logical_s2; }
756 { $$ = parse_f_type (pstate)->builtin_logical_s1; }
758 { $$ = parse_f_type (pstate)->builtin_real; }
760 { $$ = parse_f_type (pstate)->builtin_real_s8; }
762 { $$ = parse_f_type (pstate)->builtin_real_s16; }
764 { $$ = parse_f_type (pstate)->builtin_complex_s8; }
766 { $$ = parse_f_type (pstate)->builtin_complex_s8; }
767 | COMPLEX_S16_KEYWORD
768 { $$ = parse_f_type (pstate)->builtin_complex_s16; }
769 | COMPLEX_S32_KEYWORD
770 { $$ = parse_f_type (pstate)->builtin_complex_s32; }
772 { $$ = parse_f_type (pstate)->builtin_real;}
774 { $$ = parse_f_type (pstate)->builtin_real_s8;}
775 | SINGLE COMPLEX_KEYWORD
776 { $$ = parse_f_type (pstate)->builtin_complex_s8;}
777 | DOUBLE COMPLEX_KEYWORD
778 { $$ = parse_f_type (pstate)->builtin_complex_s16;}
783 { $$ = (struct type **) malloc (sizeof (struct type *) * 2);
784 $<ivec>$[0] = 1; /* Number of types in vector */
787 | nonempty_typelist ',' type
788 { int len = sizeof (struct type *) * (++($<ivec>1[0]) + 1);
789 $$ = (struct type **) realloc ((char *) $1, len);
790 $$[$<ivec>$[0]] = $3;
798 name_not_typename : NAME
799 /* These would be useful if name_not_typename was useful, but it is just
800 a fake for "variable", so these cause reduce/reduce conflicts because
801 the parser can't tell whether NAME_OR_INT is a name_not_typename (=variable,
802 =exp) or just an exp. If name_not_typename was ever used in an lvalue
803 context where only a name could occur, this might be useful.
810 /* Take care of parsing a number (anything that starts with a digit).
811 Set yylval and return the token type; update lexptr.
812 LEN is the number of characters in it. */
814 /*** Needs some error checking for the float case ***/
817 parse_number (struct parser_state *par_state,
818 const char *p, int len, int parsed_float, YYSTYPE *putithere)
823 int base = input_radix;
827 struct type *signed_type;
828 struct type *unsigned_type;
832 /* It's a float since it contains a point or an exponent. */
833 /* [dD] is not understood as an exponent by parse_float,
838 for (tmp2 = tmp; *tmp2; ++tmp2)
839 if (*tmp2 == 'd' || *tmp2 == 'D')
842 /* FIXME: Should this use different types? */
843 putithere->typed_val_float.type = parse_f_type (pstate)->builtin_real_s8;
844 bool parsed = parse_float (tmp, len,
845 putithere->typed_val_float.type,
846 putithere->typed_val_float.val);
848 return parsed? FLOAT : ERROR;
851 /* Handle base-switching prefixes 0x, 0t, 0d, 0 */
887 if (len == 0 && c == 'l')
889 else if (len == 0 && c == 'u')
894 if (c >= '0' && c <= '9')
896 else if (c >= 'a' && c <= 'f')
899 return ERROR; /* Char not a digit */
901 return ERROR; /* Invalid digit in this base */
905 /* Portably test for overflow (only works for nonzero values, so make
906 a second check for zero). */
907 if ((prevn >= n) && n != 0)
908 unsigned_p=1; /* Try something unsigned */
909 /* If range checking enabled, portably test for unsigned overflow. */
910 if (RANGE_CHECK && n != 0)
912 if ((unsigned_p && (unsigned)prevn >= (unsigned)n))
913 range_error (_("Overflow on numeric constant."));
918 /* If the number is too big to be an int, or it's got an l suffix
919 then it's a long. Work out if this has to be a long by
920 shifting right and seeing if anything remains, and the
921 target int size is different to the target long size.
923 In the expression below, we could have tested
924 (n >> gdbarch_int_bit (parse_gdbarch))
925 to see if it was zero,
926 but too many compilers warn about that, when ints and longs
927 are the same size. So we shift it twice, with fewer bits
928 each time, for the same result. */
930 if ((gdbarch_int_bit (par_state->gdbarch ())
931 != gdbarch_long_bit (par_state->gdbarch ())
933 >> (gdbarch_int_bit (par_state->gdbarch ())-2))) /* Avoid
937 high_bit = ((ULONGEST)1)
938 << (gdbarch_long_bit (par_state->gdbarch ())-1);
939 unsigned_type = parse_type (par_state)->builtin_unsigned_long;
940 signed_type = parse_type (par_state)->builtin_long;
945 ((ULONGEST)1) << (gdbarch_int_bit (par_state->gdbarch ()) - 1);
946 unsigned_type = parse_type (par_state)->builtin_unsigned_int;
947 signed_type = parse_type (par_state)->builtin_int;
950 putithere->typed_val.val = n;
952 /* If the high bit of the worked out type is set then this number
953 has to be unsigned. */
955 if (unsigned_p || (n & high_bit))
956 putithere->typed_val.type = unsigned_type;
958 putithere->typed_val.type = signed_type;
963 /* Called to setup the type stack when we encounter a '(kind=N)' type
964 modifier, performs some bounds checking on 'N' and then pushes this to
965 the type stack followed by the 'tp_kind' marker. */
967 push_kind_type (LONGEST val, struct type *type)
971 if (type->is_unsigned ())
973 ULONGEST uval = static_cast <ULONGEST> (val);
975 error (_("kind value out of range"));
976 ival = static_cast <int> (uval);
980 if (val > INT_MAX || val < 0)
981 error (_("kind value out of range"));
982 ival = static_cast <int> (val);
985 type_stack->push (ival);
986 type_stack->push (tp_kind);
989 /* Called when a type has a '(kind=N)' modifier after it, for example
990 'character(kind=1)'. The BASETYPE is the type described by 'character'
991 in our example, and KIND is the integer '1'. This function returns a
992 new type that represents the basetype of a specific kind. */
994 convert_to_kind_type (struct type *basetype, int kind)
996 if (basetype == parse_f_type (pstate)->builtin_character)
998 /* Character of kind 1 is a special case, this is the same as the
999 base character type. */
1001 return parse_f_type (pstate)->builtin_character;
1003 else if (basetype == parse_f_type (pstate)->builtin_complex_s8)
1006 return parse_f_type (pstate)->builtin_complex_s8;
1008 return parse_f_type (pstate)->builtin_complex_s16;
1009 else if (kind == 16)
1010 return parse_f_type (pstate)->builtin_complex_s32;
1012 else if (basetype == parse_f_type (pstate)->builtin_real)
1015 return parse_f_type (pstate)->builtin_real;
1017 return parse_f_type (pstate)->builtin_real_s8;
1018 else if (kind == 16)
1019 return parse_f_type (pstate)->builtin_real_s16;
1021 else if (basetype == parse_f_type (pstate)->builtin_logical)
1024 return parse_f_type (pstate)->builtin_logical_s1;
1026 return parse_f_type (pstate)->builtin_logical_s2;
1028 return parse_f_type (pstate)->builtin_logical;
1030 return parse_f_type (pstate)->builtin_logical_s8;
1032 else if (basetype == parse_f_type (pstate)->builtin_integer)
1035 return parse_f_type (pstate)->builtin_integer_s2;
1037 return parse_f_type (pstate)->builtin_integer;
1039 return parse_f_type (pstate)->builtin_integer_s8;
1042 error (_("unsupported kind %d for type %s"),
1043 kind, TYPE_SAFE_NAME (basetype));
1045 /* Should never get here. */
1051 /* The string to match against. */
1054 /* The lexer token to return. */
1057 /* The expression opcode to embed within the token. */
1058 enum exp_opcode opcode;
1060 /* When this is true the string in OPER is matched exactly including
1061 case, when this is false OPER is matched case insensitively. */
1062 bool case_sensitive;
1065 /* List of Fortran operators. */
1067 static const struct token fortran_operators[] =
1069 { ".and.", BOOL_AND, OP_NULL, false },
1070 { ".or.", BOOL_OR, OP_NULL, false },
1071 { ".not.", BOOL_NOT, OP_NULL, false },
1072 { ".eq.", EQUAL, OP_NULL, false },
1073 { ".eqv.", EQUAL, OP_NULL, false },
1074 { ".neqv.", NOTEQUAL, OP_NULL, false },
1075 { ".xor.", NOTEQUAL, OP_NULL, false },
1076 { "==", EQUAL, OP_NULL, false },
1077 { ".ne.", NOTEQUAL, OP_NULL, false },
1078 { "/=", NOTEQUAL, OP_NULL, false },
1079 { ".le.", LEQ, OP_NULL, false },
1080 { "<=", LEQ, OP_NULL, false },
1081 { ".ge.", GEQ, OP_NULL, false },
1082 { ">=", GEQ, OP_NULL, false },
1083 { ".gt.", GREATERTHAN, OP_NULL, false },
1084 { ">", GREATERTHAN, OP_NULL, false },
1085 { ".lt.", LESSTHAN, OP_NULL, false },
1086 { "<", LESSTHAN, OP_NULL, false },
1087 { "**", STARSTAR, BINOP_EXP, false },
1090 /* Holds the Fortran representation of a boolean, and the integer value we
1091 substitute in when one of the matching strings is parsed. */
1092 struct f77_boolean_val
1094 /* The string representing a Fortran boolean. */
1097 /* The integer value to replace it with. */
1101 /* The set of Fortran booleans. These are matched case insensitively. */
1102 static const struct f77_boolean_val boolean_values[] =
1108 static const struct token f77_keywords[] =
1110 /* Historically these have always been lowercase only in GDB. */
1111 { "complex_16", COMPLEX_S16_KEYWORD, OP_NULL, true },
1112 { "complex_32", COMPLEX_S32_KEYWORD, OP_NULL, true },
1113 { "character", CHARACTER, OP_NULL, true },
1114 { "integer_2", INT_S2_KEYWORD, OP_NULL, true },
1115 { "logical_1", LOGICAL_S1_KEYWORD, OP_NULL, true },
1116 { "logical_2", LOGICAL_S2_KEYWORD, OP_NULL, true },
1117 { "logical_8", LOGICAL_S8_KEYWORD, OP_NULL, true },
1118 { "complex_8", COMPLEX_S8_KEYWORD, OP_NULL, true },
1119 { "integer", INT_KEYWORD, OP_NULL, true },
1120 { "logical", LOGICAL_KEYWORD, OP_NULL, true },
1121 { "real_16", REAL_S16_KEYWORD, OP_NULL, true },
1122 { "complex", COMPLEX_KEYWORD, OP_NULL, true },
1123 { "sizeof", SIZEOF, OP_NULL, true },
1124 { "real_8", REAL_S8_KEYWORD, OP_NULL, true },
1125 { "real", REAL_KEYWORD, OP_NULL, true },
1126 { "single", SINGLE, OP_NULL, true },
1127 { "double", DOUBLE, OP_NULL, true },
1128 { "precision", PRECISION, OP_NULL, true },
1129 /* The following correspond to actual functions in Fortran and are case
1131 { "kind", KIND, OP_NULL, false },
1132 { "abs", UNOP_INTRINSIC, UNOP_ABS, false },
1133 { "mod", BINOP_INTRINSIC, BINOP_MOD, false },
1134 { "floor", UNOP_INTRINSIC, UNOP_FORTRAN_FLOOR, false },
1135 { "ceiling", UNOP_INTRINSIC, UNOP_FORTRAN_CEILING, false },
1136 { "modulo", BINOP_INTRINSIC, BINOP_FORTRAN_MODULO, false },
1137 { "cmplx", BINOP_INTRINSIC, BINOP_FORTRAN_CMPLX, false },
1138 { "lbound", UNOP_OR_BINOP_INTRINSIC, FORTRAN_LBOUND, false },
1139 { "ubound", UNOP_OR_BINOP_INTRINSIC, FORTRAN_UBOUND, false },
1140 { "allocated", UNOP_INTRINSIC, UNOP_FORTRAN_ALLOCATED, false },
1141 { "associated", UNOP_OR_BINOP_INTRINSIC, FORTRAN_ASSOCIATED, false },
1144 /* Implementation of a dynamically expandable buffer for processing input
1145 characters acquired through lexptr and building a value to return in
1146 yylval. Ripped off from ch-exp.y */
1148 static char *tempbuf; /* Current buffer contents */
1149 static int tempbufsize; /* Size of allocated buffer */
1150 static int tempbufindex; /* Current index into buffer */
1152 #define GROWBY_MIN_SIZE 64 /* Minimum amount to grow buffer by */
1154 #define CHECKBUF(size) \
1156 if (tempbufindex + (size) >= tempbufsize) \
1158 growbuf_by_size (size); \
1163 /* Grow the static temp buffer if necessary, including allocating the
1164 first one on demand. */
1167 growbuf_by_size (int count)
1171 growby = std::max (count, GROWBY_MIN_SIZE);
1172 tempbufsize += growby;
1173 if (tempbuf == NULL)
1174 tempbuf = (char *) malloc (tempbufsize);
1176 tempbuf = (char *) realloc (tempbuf, tempbufsize);
1179 /* Blatantly ripped off from ch-exp.y. This routine recognizes F77
1182 Recognize a string literal. A string literal is a nonzero sequence
1183 of characters enclosed in matching single quotes, except that
1184 a single character inside single quotes is a character literal, which
1185 we reject as a string literal. To embed the terminator character inside
1186 a string, it is simply doubled (I.E. 'this''is''one''string') */
1189 match_string_literal (void)
1191 const char *tokptr = pstate->lexptr;
1193 for (tempbufindex = 0, tokptr++; *tokptr != '\0'; tokptr++)
1196 if (*tokptr == *pstate->lexptr)
1198 if (*(tokptr + 1) == *pstate->lexptr)
1203 tempbuf[tempbufindex++] = *tokptr;
1205 if (*tokptr == '\0' /* no terminator */
1206 || tempbufindex == 0) /* no string */
1210 tempbuf[tempbufindex] = '\0';
1211 yylval.sval.ptr = tempbuf;
1212 yylval.sval.length = tempbufindex;
1213 pstate->lexptr = ++tokptr;
1214 return STRING_LITERAL;
1218 /* This is set if a NAME token appeared at the very end of the input
1219 string, with no whitespace separating the name from the EOF. This
1220 is used only when parsing to do field name completion. */
1221 static bool saw_name_at_eof;
1223 /* This is set if the previously-returned token was a structure
1225 static bool last_was_structop;
1227 /* Read one token, getting characters through lexptr. */
1235 const char *tokstart;
1236 bool saw_structop = last_was_structop;
1238 last_was_structop = false;
1242 pstate->prev_lexptr = pstate->lexptr;
1244 tokstart = pstate->lexptr;
1246 /* First of all, let us make sure we are not dealing with the
1247 special tokens .true. and .false. which evaluate to 1 and 0. */
1249 if (*pstate->lexptr == '.')
1251 for (int i = 0; i < ARRAY_SIZE (boolean_values); i++)
1253 if (strncasecmp (tokstart, boolean_values[i].name,
1254 strlen (boolean_values[i].name)) == 0)
1256 pstate->lexptr += strlen (boolean_values[i].name);
1257 yylval.lval = boolean_values[i].value;
1258 return BOOLEAN_LITERAL;
1263 /* See if it is a Fortran operator. */
1264 for (int i = 0; i < ARRAY_SIZE (fortran_operators); i++)
1265 if (strncasecmp (tokstart, fortran_operators[i].oper,
1266 strlen (fortran_operators[i].oper)) == 0)
1268 gdb_assert (!fortran_operators[i].case_sensitive);
1269 pstate->lexptr += strlen (fortran_operators[i].oper);
1270 yylval.opcode = fortran_operators[i].opcode;
1271 return fortran_operators[i].token;
1274 switch (c = *tokstart)
1277 if (saw_name_at_eof)
1279 saw_name_at_eof = false;
1282 else if (pstate->parse_completion && saw_structop)
1293 token = match_string_literal ();
1304 if (paren_depth == 0)
1311 if (pstate->comma_terminates && paren_depth == 0)
1317 /* Might be a floating point number. */
1318 if (pstate->lexptr[1] < '0' || pstate->lexptr[1] > '9')
1319 goto symbol; /* Nope, must be a symbol. */
1333 /* It's a number. */
1334 int got_dot = 0, got_e = 0, got_d = 0, toktype;
1335 const char *p = tokstart;
1336 int hex = input_radix > 10;
1338 if (c == '0' && (p[1] == 'x' || p[1] == 'X'))
1343 else if (c == '0' && (p[1]=='t' || p[1]=='T'
1344 || p[1]=='d' || p[1]=='D'))
1352 if (!hex && !got_e && (*p == 'e' || *p == 'E'))
1353 got_dot = got_e = 1;
1354 else if (!hex && !got_d && (*p == 'd' || *p == 'D'))
1355 got_dot = got_d = 1;
1356 else if (!hex && !got_dot && *p == '.')
1358 else if (((got_e && (p[-1] == 'e' || p[-1] == 'E'))
1359 || (got_d && (p[-1] == 'd' || p[-1] == 'D')))
1360 && (*p == '-' || *p == '+'))
1361 /* This is the sign of the exponent, not the end of the
1364 /* We will take any letters or digits. parse_number will
1365 complain if past the radix, or if L or U are not final. */
1366 else if ((*p < '0' || *p > '9')
1367 && ((*p < 'a' || *p > 'z')
1368 && (*p < 'A' || *p > 'Z')))
1371 toktype = parse_number (pstate, tokstart, p - tokstart,
1372 got_dot|got_e|got_d,
1374 if (toktype == ERROR)
1376 char *err_copy = (char *) alloca (p - tokstart + 1);
1378 memcpy (err_copy, tokstart, p - tokstart);
1379 err_copy[p - tokstart] = 0;
1380 error (_("Invalid number \"%s\"."), err_copy);
1387 last_was_structop = true;
1413 if (!(c == '_' || c == '$' || c ==':'
1414 || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')))
1415 /* We must have come across a bad character (e.g. ';'). */
1416 error (_("Invalid character '%c' in expression."), c);
1419 for (c = tokstart[namelen];
1420 (c == '_' || c == '$' || c == ':' || (c >= '0' && c <= '9')
1421 || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'));
1422 c = tokstart[++namelen]);
1424 /* The token "if" terminates the expression and is NOT
1425 removed from the input stream. */
1427 if (namelen == 2 && tokstart[0] == 'i' && tokstart[1] == 'f')
1430 pstate->lexptr += namelen;
1432 /* Catch specific keywords. */
1434 for (int i = 0; i < ARRAY_SIZE (f77_keywords); i++)
1435 if (strlen (f77_keywords[i].oper) == namelen
1436 && ((!f77_keywords[i].case_sensitive
1437 && strncasecmp (tokstart, f77_keywords[i].oper, namelen) == 0)
1438 || (f77_keywords[i].case_sensitive
1439 && strncmp (tokstart, f77_keywords[i].oper, namelen) == 0)))
1441 yylval.opcode = f77_keywords[i].opcode;
1442 return f77_keywords[i].token;
1445 yylval.sval.ptr = tokstart;
1446 yylval.sval.length = namelen;
1448 if (*tokstart == '$')
1449 return DOLLAR_VARIABLE;
1451 /* Use token-type TYPENAME for symbols that happen to be defined
1452 currently as names of types; NAME for other symbols.
1453 The caller is not constrained to care about the distinction. */
1455 std::string tmp = copy_name (yylval.sval);
1456 struct block_symbol result;
1457 enum domain_enum_tag lookup_domains[] =
1465 for (int i = 0; i < ARRAY_SIZE (lookup_domains); ++i)
1467 result = lookup_symbol (tmp.c_str (), pstate->expression_context_block,
1468 lookup_domains[i], NULL);
1469 if (result.symbol && SYMBOL_CLASS (result.symbol) == LOC_TYPEDEF)
1471 yylval.tsym.type = SYMBOL_TYPE (result.symbol);
1480 = language_lookup_primitive_type (pstate->language (),
1481 pstate->gdbarch (), tmp.c_str ());
1482 if (yylval.tsym.type != NULL)
1485 /* Input names that aren't symbols but ARE valid hex numbers,
1486 when the input radix permits them, can be names or numbers
1487 depending on the parse. Note we support radixes > 16 here. */
1489 && ((tokstart[0] >= 'a' && tokstart[0] < 'a' + input_radix - 10)
1490 || (tokstart[0] >= 'A' && tokstart[0] < 'A' + input_radix - 10)))
1492 YYSTYPE newlval; /* Its value is ignored. */
1493 hextype = parse_number (pstate, tokstart, namelen, 0, &newlval);
1496 yylval.ssym.sym = result;
1497 yylval.ssym.is_a_field_of_this = false;
1502 if (pstate->parse_completion && *pstate->lexptr == '\0')
1503 saw_name_at_eof = true;
1505 /* Any other kind of symbol */
1506 yylval.ssym.sym = result;
1507 yylval.ssym.is_a_field_of_this = false;
1513 f_language::parser (struct parser_state *par_state) const
1515 /* Setting up the parser state. */
1516 scoped_restore pstate_restore = make_scoped_restore (&pstate);
1517 scoped_restore restore_yydebug = make_scoped_restore (&yydebug,
1519 gdb_assert (par_state != NULL);
1521 last_was_structop = false;
1522 saw_name_at_eof = false;
1525 struct type_stack stack;
1526 scoped_restore restore_type_stack = make_scoped_restore (&type_stack,
1529 int result = yyparse ();
1531 pstate->set_operation (pstate->pop ());
1536 yyerror (const char *msg)
1538 if (pstate->prev_lexptr)
1539 pstate->lexptr = pstate->prev_lexptr;
1541 error (_("A %s in expression, near `%s'."), msg, pstate->lexptr);