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> ();
334 gdb_assert_not_reached ("unhandled intrinsic");
339 exp : BINOP_INTRINSIC '(' exp ',' exp ')'
344 pstate->wrap2<fortran_mod_operation> ();
346 case BINOP_FORTRAN_MODULO:
347 pstate->wrap2<fortran_modulo_operation> ();
349 case BINOP_FORTRAN_CMPLX:
350 pstate->wrap2<fortran_cmplx_operation> ();
353 gdb_assert_not_reached ("unhandled intrinsic");
362 { pstate->arglist_len = 1; }
366 { pstate->arglist_len = 1; }
369 arglist : arglist ',' exp %prec ABOVE_COMMA
370 { pstate->arglist_len++; }
373 arglist : arglist ',' subrange %prec ABOVE_COMMA
374 { pstate->arglist_len++; }
377 /* There are four sorts of subrange types in F90. */
379 subrange: exp ':' exp %prec ABOVE_COMMA
381 operation_up high = pstate->pop ();
382 operation_up low = pstate->pop ();
383 pstate->push_new<fortran_range_operation>
384 (RANGE_STANDARD, std::move (low),
385 std::move (high), operation_up ());
389 subrange: exp ':' %prec ABOVE_COMMA
391 operation_up low = pstate->pop ();
392 pstate->push_new<fortran_range_operation>
393 (RANGE_HIGH_BOUND_DEFAULT, std::move (low),
394 operation_up (), operation_up ());
398 subrange: ':' exp %prec ABOVE_COMMA
400 operation_up high = pstate->pop ();
401 pstate->push_new<fortran_range_operation>
402 (RANGE_LOW_BOUND_DEFAULT, operation_up (),
403 std::move (high), operation_up ());
407 subrange: ':' %prec ABOVE_COMMA
409 pstate->push_new<fortran_range_operation>
410 (RANGE_LOW_BOUND_DEFAULT
411 | RANGE_HIGH_BOUND_DEFAULT,
412 operation_up (), operation_up (),
417 /* And each of the four subrange types can also have a stride. */
418 subrange: exp ':' exp ':' exp %prec ABOVE_COMMA
420 operation_up stride = pstate->pop ();
421 operation_up high = pstate->pop ();
422 operation_up low = pstate->pop ();
423 pstate->push_new<fortran_range_operation>
424 (RANGE_STANDARD | RANGE_HAS_STRIDE,
425 std::move (low), std::move (high),
430 subrange: exp ':' ':' exp %prec ABOVE_COMMA
432 operation_up stride = pstate->pop ();
433 operation_up low = pstate->pop ();
434 pstate->push_new<fortran_range_operation>
435 (RANGE_HIGH_BOUND_DEFAULT
437 std::move (low), operation_up (),
442 subrange: ':' exp ':' exp %prec ABOVE_COMMA
444 operation_up stride = pstate->pop ();
445 operation_up high = pstate->pop ();
446 pstate->push_new<fortran_range_operation>
447 (RANGE_LOW_BOUND_DEFAULT
449 operation_up (), std::move (high),
454 subrange: ':' ':' exp %prec ABOVE_COMMA
456 operation_up stride = pstate->pop ();
457 pstate->push_new<fortran_range_operation>
458 (RANGE_LOW_BOUND_DEFAULT
459 | RANGE_HIGH_BOUND_DEFAULT
461 operation_up (), operation_up (),
466 complexnum: exp ',' exp
470 exp : '(' complexnum ')'
472 operation_up rhs = pstate->pop ();
473 operation_up lhs = pstate->pop ();
474 pstate->push_new<complex_operation>
475 (std::move (lhs), std::move (rhs),
476 parse_f_type (pstate)->builtin_complex_s16);
480 exp : '(' type ')' exp %prec UNARY
482 pstate->push_new<unop_cast_operation>
483 (pstate->pop (), $2);
489 pstate->push_new<structop_operation>
490 (pstate->pop (), copy_name ($3));
494 exp : exp '%' name COMPLETE
496 structop_base_operation *op
497 = new structop_operation (pstate->pop (),
499 pstate->mark_struct_expression (op);
500 pstate->push (operation_up (op));
504 exp : exp '%' COMPLETE
506 structop_base_operation *op
507 = new structop_operation (pstate->pop (), "");
508 pstate->mark_struct_expression (op);
509 pstate->push (operation_up (op));
513 /* Binary operators in order of decreasing precedence. */
516 { pstate->wrap2<repeat_operation> (); }
519 exp : exp STARSTAR exp
520 { pstate->wrap2<exp_operation> (); }
524 { pstate->wrap2<mul_operation> (); }
528 { pstate->wrap2<div_operation> (); }
532 { pstate->wrap2<add_operation> (); }
536 { pstate->wrap2<sub_operation> (); }
540 { pstate->wrap2<lsh_operation> (); }
544 { pstate->wrap2<rsh_operation> (); }
548 { pstate->wrap2<equal_operation> (); }
551 exp : exp NOTEQUAL exp
552 { pstate->wrap2<notequal_operation> (); }
556 { pstate->wrap2<leq_operation> (); }
560 { pstate->wrap2<geq_operation> (); }
563 exp : exp LESSTHAN exp
564 { pstate->wrap2<less_operation> (); }
567 exp : exp GREATERTHAN exp
568 { pstate->wrap2<gtr_operation> (); }
572 { pstate->wrap2<bitwise_and_operation> (); }
576 { pstate->wrap2<bitwise_xor_operation> (); }
580 { pstate->wrap2<bitwise_ior_operation> (); }
583 exp : exp BOOL_AND exp
584 { pstate->wrap2<logical_and_operation> (); }
588 exp : exp BOOL_OR exp
589 { pstate->wrap2<logical_or_operation> (); }
593 { pstate->wrap2<assign_operation> (); }
596 exp : exp ASSIGN_MODIFY exp
598 operation_up rhs = pstate->pop ();
599 operation_up lhs = pstate->pop ();
600 pstate->push_new<assign_modify_operation>
601 ($2, std::move (lhs), std::move (rhs));
607 pstate->push_new<long_const_operation>
614 parse_number (pstate, $1.stoken.ptr,
615 $1.stoken.length, 0, &val);
616 pstate->push_new<long_const_operation>
625 std::copy (std::begin ($1.val), std::end ($1.val),
627 pstate->push_new<float_const_operation> ($1.type, data);
634 exp : DOLLAR_VARIABLE
635 { pstate->push_dollar ($1); }
638 exp : SIZEOF '(' type ')' %prec UNARY
640 $3 = check_typedef ($3);
641 pstate->push_new<long_const_operation>
642 (parse_f_type (pstate)->builtin_integer,
647 exp : BOOLEAN_LITERAL
648 { pstate->push_new<bool_operation> ($1); }
653 pstate->push_new<string_operation>
658 variable: name_not_typename
659 { struct block_symbol sym = $1.sym;
660 std::string name = copy_name ($1.stoken);
661 pstate->push_symbol (name.c_str (), sym);
672 /* This is where the interesting stuff happens. */
675 struct type *follow_type = $1;
676 struct type *range_type;
679 switch (type_stack->pop ())
685 follow_type = lookup_pointer_type (follow_type);
688 follow_type = lookup_lvalue_reference_type (follow_type);
691 array_size = type_stack->pop_int ();
692 if (array_size != -1)
695 create_static_range_type ((struct type *) NULL,
696 parse_f_type (pstate)
700 create_array_type ((struct type *) NULL,
701 follow_type, range_type);
704 follow_type = lookup_pointer_type (follow_type);
707 follow_type = lookup_function_type (follow_type);
711 int kind_val = type_stack->pop_int ();
713 = convert_to_kind_type (follow_type, kind_val);
722 { type_stack->push (tp_pointer); $$ = 0; }
724 { type_stack->push (tp_pointer); $$ = $2; }
726 { type_stack->push (tp_reference); $$ = 0; }
728 { type_stack->push (tp_reference); $$ = $2; }
732 direct_abs_decl: '(' abs_decl ')'
734 | '(' KIND '=' INT ')'
735 { push_kind_type ($4.val, $4.type); }
737 { push_kind_type ($2.val, $2.type); }
738 | direct_abs_decl func_mod
739 { type_stack->push (tp_function); }
741 { type_stack->push (tp_function); }
746 | '(' nonempty_typelist ')'
747 { free ($2); $$ = 0; }
750 typebase /* Implements (approximately): (type-qualifier)* type-specifier */
754 { $$ = parse_f_type (pstate)->builtin_integer; }
756 { $$ = parse_f_type (pstate)->builtin_integer_s2; }
758 { $$ = parse_f_type (pstate)->builtin_character; }
760 { $$ = parse_f_type (pstate)->builtin_logical_s8; }
762 { $$ = parse_f_type (pstate)->builtin_logical; }
764 { $$ = parse_f_type (pstate)->builtin_logical_s2; }
766 { $$ = parse_f_type (pstate)->builtin_logical_s1; }
768 { $$ = parse_f_type (pstate)->builtin_real; }
770 { $$ = parse_f_type (pstate)->builtin_real_s8; }
772 { $$ = parse_f_type (pstate)->builtin_real_s16; }
774 { $$ = parse_f_type (pstate)->builtin_complex_s8; }
776 { $$ = parse_f_type (pstate)->builtin_complex_s8; }
777 | COMPLEX_S16_KEYWORD
778 { $$ = parse_f_type (pstate)->builtin_complex_s16; }
779 | COMPLEX_S32_KEYWORD
780 { $$ = parse_f_type (pstate)->builtin_complex_s32; }
782 { $$ = parse_f_type (pstate)->builtin_real;}
784 { $$ = parse_f_type (pstate)->builtin_real_s8;}
785 | SINGLE COMPLEX_KEYWORD
786 { $$ = parse_f_type (pstate)->builtin_complex_s8;}
787 | DOUBLE COMPLEX_KEYWORD
788 { $$ = parse_f_type (pstate)->builtin_complex_s16;}
793 { $$ = (struct type **) malloc (sizeof (struct type *) * 2);
794 $<ivec>$[0] = 1; /* Number of types in vector */
797 | nonempty_typelist ',' type
798 { int len = sizeof (struct type *) * (++($<ivec>1[0]) + 1);
799 $$ = (struct type **) realloc ((char *) $1, len);
800 $$[$<ivec>$[0]] = $3;
808 name_not_typename : NAME
809 /* These would be useful if name_not_typename was useful, but it is just
810 a fake for "variable", so these cause reduce/reduce conflicts because
811 the parser can't tell whether NAME_OR_INT is a name_not_typename (=variable,
812 =exp) or just an exp. If name_not_typename was ever used in an lvalue
813 context where only a name could occur, this might be useful.
820 /* Take care of parsing a number (anything that starts with a digit).
821 Set yylval and return the token type; update lexptr.
822 LEN is the number of characters in it. */
824 /*** Needs some error checking for the float case ***/
827 parse_number (struct parser_state *par_state,
828 const char *p, int len, int parsed_float, YYSTYPE *putithere)
833 int base = input_radix;
837 struct type *signed_type;
838 struct type *unsigned_type;
842 /* It's a float since it contains a point or an exponent. */
843 /* [dD] is not understood as an exponent by parse_float,
848 for (tmp2 = tmp; *tmp2; ++tmp2)
849 if (*tmp2 == 'd' || *tmp2 == 'D')
852 /* FIXME: Should this use different types? */
853 putithere->typed_val_float.type = parse_f_type (pstate)->builtin_real_s8;
854 bool parsed = parse_float (tmp, len,
855 putithere->typed_val_float.type,
856 putithere->typed_val_float.val);
858 return parsed? FLOAT : ERROR;
861 /* Handle base-switching prefixes 0x, 0t, 0d, 0 */
897 if (len == 0 && c == 'l')
899 else if (len == 0 && c == 'u')
904 if (c >= '0' && c <= '9')
906 else if (c >= 'a' && c <= 'f')
909 return ERROR; /* Char not a digit */
911 return ERROR; /* Invalid digit in this base */
915 /* Portably test for overflow (only works for nonzero values, so make
916 a second check for zero). */
917 if ((prevn >= n) && n != 0)
918 unsigned_p=1; /* Try something unsigned */
919 /* If range checking enabled, portably test for unsigned overflow. */
920 if (RANGE_CHECK && n != 0)
922 if ((unsigned_p && (unsigned)prevn >= (unsigned)n))
923 range_error (_("Overflow on numeric constant."));
928 /* If the number is too big to be an int, or it's got an l suffix
929 then it's a long. Work out if this has to be a long by
930 shifting right and seeing if anything remains, and the
931 target int size is different to the target long size.
933 In the expression below, we could have tested
934 (n >> gdbarch_int_bit (parse_gdbarch))
935 to see if it was zero,
936 but too many compilers warn about that, when ints and longs
937 are the same size. So we shift it twice, with fewer bits
938 each time, for the same result. */
940 if ((gdbarch_int_bit (par_state->gdbarch ())
941 != gdbarch_long_bit (par_state->gdbarch ())
943 >> (gdbarch_int_bit (par_state->gdbarch ())-2))) /* Avoid
947 high_bit = ((ULONGEST)1)
948 << (gdbarch_long_bit (par_state->gdbarch ())-1);
949 unsigned_type = parse_type (par_state)->builtin_unsigned_long;
950 signed_type = parse_type (par_state)->builtin_long;
955 ((ULONGEST)1) << (gdbarch_int_bit (par_state->gdbarch ()) - 1);
956 unsigned_type = parse_type (par_state)->builtin_unsigned_int;
957 signed_type = parse_type (par_state)->builtin_int;
960 putithere->typed_val.val = n;
962 /* If the high bit of the worked out type is set then this number
963 has to be unsigned. */
965 if (unsigned_p || (n & high_bit))
966 putithere->typed_val.type = unsigned_type;
968 putithere->typed_val.type = signed_type;
973 /* Called to setup the type stack when we encounter a '(kind=N)' type
974 modifier, performs some bounds checking on 'N' and then pushes this to
975 the type stack followed by the 'tp_kind' marker. */
977 push_kind_type (LONGEST val, struct type *type)
981 if (type->is_unsigned ())
983 ULONGEST uval = static_cast <ULONGEST> (val);
985 error (_("kind value out of range"));
986 ival = static_cast <int> (uval);
990 if (val > INT_MAX || val < 0)
991 error (_("kind value out of range"));
992 ival = static_cast <int> (val);
995 type_stack->push (ival);
996 type_stack->push (tp_kind);
999 /* Called when a type has a '(kind=N)' modifier after it, for example
1000 'character(kind=1)'. The BASETYPE is the type described by 'character'
1001 in our example, and KIND is the integer '1'. This function returns a
1002 new type that represents the basetype of a specific kind. */
1003 static struct type *
1004 convert_to_kind_type (struct type *basetype, int kind)
1006 if (basetype == parse_f_type (pstate)->builtin_character)
1008 /* Character of kind 1 is a special case, this is the same as the
1009 base character type. */
1011 return parse_f_type (pstate)->builtin_character;
1013 else if (basetype == parse_f_type (pstate)->builtin_complex_s8)
1016 return parse_f_type (pstate)->builtin_complex_s8;
1018 return parse_f_type (pstate)->builtin_complex_s16;
1019 else if (kind == 16)
1020 return parse_f_type (pstate)->builtin_complex_s32;
1022 else if (basetype == parse_f_type (pstate)->builtin_real)
1025 return parse_f_type (pstate)->builtin_real;
1027 return parse_f_type (pstate)->builtin_real_s8;
1028 else if (kind == 16)
1029 return parse_f_type (pstate)->builtin_real_s16;
1031 else if (basetype == parse_f_type (pstate)->builtin_logical)
1034 return parse_f_type (pstate)->builtin_logical_s1;
1036 return parse_f_type (pstate)->builtin_logical_s2;
1038 return parse_f_type (pstate)->builtin_logical;
1040 return parse_f_type (pstate)->builtin_logical_s8;
1042 else if (basetype == parse_f_type (pstate)->builtin_integer)
1045 return parse_f_type (pstate)->builtin_integer_s2;
1047 return parse_f_type (pstate)->builtin_integer;
1049 return parse_f_type (pstate)->builtin_integer_s8;
1052 error (_("unsupported kind %d for type %s"),
1053 kind, TYPE_SAFE_NAME (basetype));
1055 /* Should never get here. */
1061 /* The string to match against. */
1064 /* The lexer token to return. */
1067 /* The expression opcode to embed within the token. */
1068 enum exp_opcode opcode;
1070 /* When this is true the string in OPER is matched exactly including
1071 case, when this is false OPER is matched case insensitively. */
1072 bool case_sensitive;
1075 /* List of Fortran operators. */
1077 static const struct token fortran_operators[] =
1079 { ".and.", BOOL_AND, OP_NULL, false },
1080 { ".or.", BOOL_OR, OP_NULL, false },
1081 { ".not.", BOOL_NOT, OP_NULL, false },
1082 { ".eq.", EQUAL, OP_NULL, false },
1083 { ".eqv.", EQUAL, OP_NULL, false },
1084 { ".neqv.", NOTEQUAL, OP_NULL, false },
1085 { ".xor.", NOTEQUAL, OP_NULL, false },
1086 { "==", EQUAL, OP_NULL, false },
1087 { ".ne.", NOTEQUAL, OP_NULL, false },
1088 { "/=", NOTEQUAL, OP_NULL, false },
1089 { ".le.", LEQ, OP_NULL, false },
1090 { "<=", LEQ, OP_NULL, false },
1091 { ".ge.", GEQ, OP_NULL, false },
1092 { ">=", GEQ, OP_NULL, false },
1093 { ".gt.", GREATERTHAN, OP_NULL, false },
1094 { ">", GREATERTHAN, OP_NULL, false },
1095 { ".lt.", LESSTHAN, OP_NULL, false },
1096 { "<", LESSTHAN, OP_NULL, false },
1097 { "**", STARSTAR, BINOP_EXP, false },
1100 /* Holds the Fortran representation of a boolean, and the integer value we
1101 substitute in when one of the matching strings is parsed. */
1102 struct f77_boolean_val
1104 /* The string representing a Fortran boolean. */
1107 /* The integer value to replace it with. */
1111 /* The set of Fortran booleans. These are matched case insensitively. */
1112 static const struct f77_boolean_val boolean_values[] =
1118 static const struct token f77_keywords[] =
1120 /* Historically these have always been lowercase only in GDB. */
1121 { "complex_16", COMPLEX_S16_KEYWORD, OP_NULL, true },
1122 { "complex_32", COMPLEX_S32_KEYWORD, OP_NULL, true },
1123 { "character", CHARACTER, OP_NULL, true },
1124 { "integer_2", INT_S2_KEYWORD, OP_NULL, true },
1125 { "logical_1", LOGICAL_S1_KEYWORD, OP_NULL, true },
1126 { "logical_2", LOGICAL_S2_KEYWORD, OP_NULL, true },
1127 { "logical_8", LOGICAL_S8_KEYWORD, OP_NULL, true },
1128 { "complex_8", COMPLEX_S8_KEYWORD, OP_NULL, true },
1129 { "integer", INT_KEYWORD, OP_NULL, true },
1130 { "logical", LOGICAL_KEYWORD, OP_NULL, true },
1131 { "real_16", REAL_S16_KEYWORD, OP_NULL, true },
1132 { "complex", COMPLEX_KEYWORD, OP_NULL, true },
1133 { "sizeof", SIZEOF, OP_NULL, true },
1134 { "real_8", REAL_S8_KEYWORD, OP_NULL, true },
1135 { "real", REAL_KEYWORD, OP_NULL, true },
1136 { "single", SINGLE, OP_NULL, true },
1137 { "double", DOUBLE, OP_NULL, true },
1138 { "precision", PRECISION, OP_NULL, true },
1139 /* The following correspond to actual functions in Fortran and are case
1141 { "kind", KIND, OP_NULL, false },
1142 { "abs", UNOP_INTRINSIC, UNOP_ABS, false },
1143 { "mod", BINOP_INTRINSIC, BINOP_MOD, false },
1144 { "floor", UNOP_INTRINSIC, UNOP_FORTRAN_FLOOR, false },
1145 { "ceiling", UNOP_INTRINSIC, UNOP_FORTRAN_CEILING, false },
1146 { "modulo", BINOP_INTRINSIC, BINOP_FORTRAN_MODULO, false },
1147 { "cmplx", BINOP_INTRINSIC, BINOP_FORTRAN_CMPLX, false },
1148 { "lbound", UNOP_OR_BINOP_INTRINSIC, FORTRAN_LBOUND, false },
1149 { "ubound", UNOP_OR_BINOP_INTRINSIC, FORTRAN_UBOUND, false },
1150 { "allocated", UNOP_INTRINSIC, UNOP_FORTRAN_ALLOCATED, false },
1151 { "associated", UNOP_OR_BINOP_INTRINSIC, FORTRAN_ASSOCIATED, false },
1152 { "rank", UNOP_INTRINSIC, UNOP_FORTRAN_RANK, false },
1153 { "size", UNOP_OR_BINOP_INTRINSIC, FORTRAN_ARRAY_SIZE, false },
1156 /* Implementation of a dynamically expandable buffer for processing input
1157 characters acquired through lexptr and building a value to return in
1158 yylval. Ripped off from ch-exp.y */
1160 static char *tempbuf; /* Current buffer contents */
1161 static int tempbufsize; /* Size of allocated buffer */
1162 static int tempbufindex; /* Current index into buffer */
1164 #define GROWBY_MIN_SIZE 64 /* Minimum amount to grow buffer by */
1166 #define CHECKBUF(size) \
1168 if (tempbufindex + (size) >= tempbufsize) \
1170 growbuf_by_size (size); \
1175 /* Grow the static temp buffer if necessary, including allocating the
1176 first one on demand. */
1179 growbuf_by_size (int count)
1183 growby = std::max (count, GROWBY_MIN_SIZE);
1184 tempbufsize += growby;
1185 if (tempbuf == NULL)
1186 tempbuf = (char *) malloc (tempbufsize);
1188 tempbuf = (char *) realloc (tempbuf, tempbufsize);
1191 /* Blatantly ripped off from ch-exp.y. This routine recognizes F77
1194 Recognize a string literal. A string literal is a nonzero sequence
1195 of characters enclosed in matching single quotes, except that
1196 a single character inside single quotes is a character literal, which
1197 we reject as a string literal. To embed the terminator character inside
1198 a string, it is simply doubled (I.E. 'this''is''one''string') */
1201 match_string_literal (void)
1203 const char *tokptr = pstate->lexptr;
1205 for (tempbufindex = 0, tokptr++; *tokptr != '\0'; tokptr++)
1208 if (*tokptr == *pstate->lexptr)
1210 if (*(tokptr + 1) == *pstate->lexptr)
1215 tempbuf[tempbufindex++] = *tokptr;
1217 if (*tokptr == '\0' /* no terminator */
1218 || tempbufindex == 0) /* no string */
1222 tempbuf[tempbufindex] = '\0';
1223 yylval.sval.ptr = tempbuf;
1224 yylval.sval.length = tempbufindex;
1225 pstate->lexptr = ++tokptr;
1226 return STRING_LITERAL;
1230 /* This is set if a NAME token appeared at the very end of the input
1231 string, with no whitespace separating the name from the EOF. This
1232 is used only when parsing to do field name completion. */
1233 static bool saw_name_at_eof;
1235 /* This is set if the previously-returned token was a structure
1237 static bool last_was_structop;
1239 /* Read one token, getting characters through lexptr. */
1247 const char *tokstart;
1248 bool saw_structop = last_was_structop;
1250 last_was_structop = false;
1254 pstate->prev_lexptr = pstate->lexptr;
1256 tokstart = pstate->lexptr;
1258 /* First of all, let us make sure we are not dealing with the
1259 special tokens .true. and .false. which evaluate to 1 and 0. */
1261 if (*pstate->lexptr == '.')
1263 for (int i = 0; i < ARRAY_SIZE (boolean_values); i++)
1265 if (strncasecmp (tokstart, boolean_values[i].name,
1266 strlen (boolean_values[i].name)) == 0)
1268 pstate->lexptr += strlen (boolean_values[i].name);
1269 yylval.lval = boolean_values[i].value;
1270 return BOOLEAN_LITERAL;
1275 /* See if it is a Fortran operator. */
1276 for (int i = 0; i < ARRAY_SIZE (fortran_operators); i++)
1277 if (strncasecmp (tokstart, fortran_operators[i].oper,
1278 strlen (fortran_operators[i].oper)) == 0)
1280 gdb_assert (!fortran_operators[i].case_sensitive);
1281 pstate->lexptr += strlen (fortran_operators[i].oper);
1282 yylval.opcode = fortran_operators[i].opcode;
1283 return fortran_operators[i].token;
1286 switch (c = *tokstart)
1289 if (saw_name_at_eof)
1291 saw_name_at_eof = false;
1294 else if (pstate->parse_completion && saw_structop)
1305 token = match_string_literal ();
1316 if (paren_depth == 0)
1323 if (pstate->comma_terminates && paren_depth == 0)
1329 /* Might be a floating point number. */
1330 if (pstate->lexptr[1] < '0' || pstate->lexptr[1] > '9')
1331 goto symbol; /* Nope, must be a symbol. */
1345 /* It's a number. */
1346 int got_dot = 0, got_e = 0, got_d = 0, toktype;
1347 const char *p = tokstart;
1348 int hex = input_radix > 10;
1350 if (c == '0' && (p[1] == 'x' || p[1] == 'X'))
1355 else if (c == '0' && (p[1]=='t' || p[1]=='T'
1356 || p[1]=='d' || p[1]=='D'))
1364 if (!hex && !got_e && (*p == 'e' || *p == 'E'))
1365 got_dot = got_e = 1;
1366 else if (!hex && !got_d && (*p == 'd' || *p == 'D'))
1367 got_dot = got_d = 1;
1368 else if (!hex && !got_dot && *p == '.')
1370 else if (((got_e && (p[-1] == 'e' || p[-1] == 'E'))
1371 || (got_d && (p[-1] == 'd' || p[-1] == 'D')))
1372 && (*p == '-' || *p == '+'))
1373 /* This is the sign of the exponent, not the end of the
1376 /* We will take any letters or digits. parse_number will
1377 complain if past the radix, or if L or U are not final. */
1378 else if ((*p < '0' || *p > '9')
1379 && ((*p < 'a' || *p > 'z')
1380 && (*p < 'A' || *p > 'Z')))
1383 toktype = parse_number (pstate, tokstart, p - tokstart,
1384 got_dot|got_e|got_d,
1386 if (toktype == ERROR)
1388 char *err_copy = (char *) alloca (p - tokstart + 1);
1390 memcpy (err_copy, tokstart, p - tokstart);
1391 err_copy[p - tokstart] = 0;
1392 error (_("Invalid number \"%s\"."), err_copy);
1399 last_was_structop = true;
1425 if (!(c == '_' || c == '$' || c ==':'
1426 || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')))
1427 /* We must have come across a bad character (e.g. ';'). */
1428 error (_("Invalid character '%c' in expression."), c);
1431 for (c = tokstart[namelen];
1432 (c == '_' || c == '$' || c == ':' || (c >= '0' && c <= '9')
1433 || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'));
1434 c = tokstart[++namelen]);
1436 /* The token "if" terminates the expression and is NOT
1437 removed from the input stream. */
1439 if (namelen == 2 && tokstart[0] == 'i' && tokstart[1] == 'f')
1442 pstate->lexptr += namelen;
1444 /* Catch specific keywords. */
1446 for (int i = 0; i < ARRAY_SIZE (f77_keywords); i++)
1447 if (strlen (f77_keywords[i].oper) == namelen
1448 && ((!f77_keywords[i].case_sensitive
1449 && strncasecmp (tokstart, f77_keywords[i].oper, namelen) == 0)
1450 || (f77_keywords[i].case_sensitive
1451 && strncmp (tokstart, f77_keywords[i].oper, namelen) == 0)))
1453 yylval.opcode = f77_keywords[i].opcode;
1454 return f77_keywords[i].token;
1457 yylval.sval.ptr = tokstart;
1458 yylval.sval.length = namelen;
1460 if (*tokstart == '$')
1461 return DOLLAR_VARIABLE;
1463 /* Use token-type TYPENAME for symbols that happen to be defined
1464 currently as names of types; NAME for other symbols.
1465 The caller is not constrained to care about the distinction. */
1467 std::string tmp = copy_name (yylval.sval);
1468 struct block_symbol result;
1469 enum domain_enum_tag lookup_domains[] =
1477 for (int i = 0; i < ARRAY_SIZE (lookup_domains); ++i)
1479 result = lookup_symbol (tmp.c_str (), pstate->expression_context_block,
1480 lookup_domains[i], NULL);
1481 if (result.symbol && SYMBOL_CLASS (result.symbol) == LOC_TYPEDEF)
1483 yylval.tsym.type = SYMBOL_TYPE (result.symbol);
1492 = language_lookup_primitive_type (pstate->language (),
1493 pstate->gdbarch (), tmp.c_str ());
1494 if (yylval.tsym.type != NULL)
1497 /* Input names that aren't symbols but ARE valid hex numbers,
1498 when the input radix permits them, can be names or numbers
1499 depending on the parse. Note we support radixes > 16 here. */
1501 && ((tokstart[0] >= 'a' && tokstart[0] < 'a' + input_radix - 10)
1502 || (tokstart[0] >= 'A' && tokstart[0] < 'A' + input_radix - 10)))
1504 YYSTYPE newlval; /* Its value is ignored. */
1505 hextype = parse_number (pstate, tokstart, namelen, 0, &newlval);
1508 yylval.ssym.sym = result;
1509 yylval.ssym.is_a_field_of_this = false;
1514 if (pstate->parse_completion && *pstate->lexptr == '\0')
1515 saw_name_at_eof = true;
1517 /* Any other kind of symbol */
1518 yylval.ssym.sym = result;
1519 yylval.ssym.is_a_field_of_this = false;
1525 f_language::parser (struct parser_state *par_state) const
1527 /* Setting up the parser state. */
1528 scoped_restore pstate_restore = make_scoped_restore (&pstate);
1529 scoped_restore restore_yydebug = make_scoped_restore (&yydebug,
1531 gdb_assert (par_state != NULL);
1533 last_was_structop = false;
1534 saw_name_at_eof = false;
1537 struct type_stack stack;
1538 scoped_restore restore_type_stack = make_scoped_restore (&type_stack,
1541 int result = yyparse ();
1543 pstate->set_operation (pstate->pop ());
1548 yyerror (const char *msg)
1550 if (pstate->prev_lexptr)
1551 pstate->lexptr = pstate->prev_lexptr;
1553 error (_("A %s in expression, near `%s'."), msg, pstate->lexptr);