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> ();
336 case UNOP_FORTRAN_LOC:
337 pstate->wrap<fortran_loc_operation> ();
340 gdb_assert_not_reached ("unhandled intrinsic");
345 exp : BINOP_INTRINSIC '(' exp ',' exp ')'
350 pstate->wrap2<fortran_mod_operation> ();
352 case BINOP_FORTRAN_MODULO:
353 pstate->wrap2<fortran_modulo_operation> ();
355 case BINOP_FORTRAN_CMPLX:
356 pstate->wrap2<fortran_cmplx_operation> ();
359 gdb_assert_not_reached ("unhandled intrinsic");
368 { pstate->arglist_len = 1; }
372 { pstate->arglist_len = 1; }
375 arglist : arglist ',' exp %prec ABOVE_COMMA
376 { pstate->arglist_len++; }
379 arglist : arglist ',' subrange %prec ABOVE_COMMA
380 { pstate->arglist_len++; }
383 /* There are four sorts of subrange types in F90. */
385 subrange: exp ':' exp %prec ABOVE_COMMA
387 operation_up high = pstate->pop ();
388 operation_up low = pstate->pop ();
389 pstate->push_new<fortran_range_operation>
390 (RANGE_STANDARD, std::move (low),
391 std::move (high), operation_up ());
395 subrange: exp ':' %prec ABOVE_COMMA
397 operation_up low = pstate->pop ();
398 pstate->push_new<fortran_range_operation>
399 (RANGE_HIGH_BOUND_DEFAULT, std::move (low),
400 operation_up (), operation_up ());
404 subrange: ':' exp %prec ABOVE_COMMA
406 operation_up high = pstate->pop ();
407 pstate->push_new<fortran_range_operation>
408 (RANGE_LOW_BOUND_DEFAULT, operation_up (),
409 std::move (high), operation_up ());
413 subrange: ':' %prec ABOVE_COMMA
415 pstate->push_new<fortran_range_operation>
416 (RANGE_LOW_BOUND_DEFAULT
417 | RANGE_HIGH_BOUND_DEFAULT,
418 operation_up (), operation_up (),
423 /* And each of the four subrange types can also have a stride. */
424 subrange: exp ':' exp ':' exp %prec ABOVE_COMMA
426 operation_up stride = pstate->pop ();
427 operation_up high = pstate->pop ();
428 operation_up low = pstate->pop ();
429 pstate->push_new<fortran_range_operation>
430 (RANGE_STANDARD | RANGE_HAS_STRIDE,
431 std::move (low), std::move (high),
436 subrange: exp ':' ':' exp %prec ABOVE_COMMA
438 operation_up stride = pstate->pop ();
439 operation_up low = pstate->pop ();
440 pstate->push_new<fortran_range_operation>
441 (RANGE_HIGH_BOUND_DEFAULT
443 std::move (low), operation_up (),
448 subrange: ':' exp ':' exp %prec ABOVE_COMMA
450 operation_up stride = pstate->pop ();
451 operation_up high = pstate->pop ();
452 pstate->push_new<fortran_range_operation>
453 (RANGE_LOW_BOUND_DEFAULT
455 operation_up (), std::move (high),
460 subrange: ':' ':' exp %prec ABOVE_COMMA
462 operation_up stride = pstate->pop ();
463 pstate->push_new<fortran_range_operation>
464 (RANGE_LOW_BOUND_DEFAULT
465 | RANGE_HIGH_BOUND_DEFAULT
467 operation_up (), operation_up (),
472 complexnum: exp ',' exp
476 exp : '(' complexnum ')'
478 operation_up rhs = pstate->pop ();
479 operation_up lhs = pstate->pop ();
480 pstate->push_new<complex_operation>
481 (std::move (lhs), std::move (rhs),
482 parse_f_type (pstate)->builtin_complex_s16);
486 exp : '(' type ')' exp %prec UNARY
488 pstate->push_new<unop_cast_operation>
489 (pstate->pop (), $2);
495 pstate->push_new<structop_operation>
496 (pstate->pop (), copy_name ($3));
500 exp : exp '%' name COMPLETE
502 structop_base_operation *op
503 = new structop_operation (pstate->pop (),
505 pstate->mark_struct_expression (op);
506 pstate->push (operation_up (op));
510 exp : exp '%' COMPLETE
512 structop_base_operation *op
513 = new structop_operation (pstate->pop (), "");
514 pstate->mark_struct_expression (op);
515 pstate->push (operation_up (op));
519 /* Binary operators in order of decreasing precedence. */
522 { pstate->wrap2<repeat_operation> (); }
525 exp : exp STARSTAR exp
526 { pstate->wrap2<exp_operation> (); }
530 { pstate->wrap2<mul_operation> (); }
534 { pstate->wrap2<div_operation> (); }
538 { pstate->wrap2<add_operation> (); }
542 { pstate->wrap2<sub_operation> (); }
546 { pstate->wrap2<lsh_operation> (); }
550 { pstate->wrap2<rsh_operation> (); }
554 { pstate->wrap2<equal_operation> (); }
557 exp : exp NOTEQUAL exp
558 { pstate->wrap2<notequal_operation> (); }
562 { pstate->wrap2<leq_operation> (); }
566 { pstate->wrap2<geq_operation> (); }
569 exp : exp LESSTHAN exp
570 { pstate->wrap2<less_operation> (); }
573 exp : exp GREATERTHAN exp
574 { pstate->wrap2<gtr_operation> (); }
578 { pstate->wrap2<bitwise_and_operation> (); }
582 { pstate->wrap2<bitwise_xor_operation> (); }
586 { pstate->wrap2<bitwise_ior_operation> (); }
589 exp : exp BOOL_AND exp
590 { pstate->wrap2<logical_and_operation> (); }
594 exp : exp BOOL_OR exp
595 { pstate->wrap2<logical_or_operation> (); }
599 { pstate->wrap2<assign_operation> (); }
602 exp : exp ASSIGN_MODIFY exp
604 operation_up rhs = pstate->pop ();
605 operation_up lhs = pstate->pop ();
606 pstate->push_new<assign_modify_operation>
607 ($2, std::move (lhs), std::move (rhs));
613 pstate->push_new<long_const_operation>
620 parse_number (pstate, $1.stoken.ptr,
621 $1.stoken.length, 0, &val);
622 pstate->push_new<long_const_operation>
631 std::copy (std::begin ($1.val), std::end ($1.val),
633 pstate->push_new<float_const_operation> ($1.type, data);
640 exp : DOLLAR_VARIABLE
641 { pstate->push_dollar ($1); }
644 exp : SIZEOF '(' type ')' %prec UNARY
646 $3 = check_typedef ($3);
647 pstate->push_new<long_const_operation>
648 (parse_f_type (pstate)->builtin_integer,
653 exp : BOOLEAN_LITERAL
654 { pstate->push_new<bool_operation> ($1); }
659 pstate->push_new<string_operation>
664 variable: name_not_typename
665 { struct block_symbol sym = $1.sym;
666 std::string name = copy_name ($1.stoken);
667 pstate->push_symbol (name.c_str (), sym);
678 /* This is where the interesting stuff happens. */
681 struct type *follow_type = $1;
682 struct type *range_type;
685 switch (type_stack->pop ())
691 follow_type = lookup_pointer_type (follow_type);
694 follow_type = lookup_lvalue_reference_type (follow_type);
697 array_size = type_stack->pop_int ();
698 if (array_size != -1)
701 create_static_range_type ((struct type *) NULL,
702 parse_f_type (pstate)
706 create_array_type ((struct type *) NULL,
707 follow_type, range_type);
710 follow_type = lookup_pointer_type (follow_type);
713 follow_type = lookup_function_type (follow_type);
717 int kind_val = type_stack->pop_int ();
719 = convert_to_kind_type (follow_type, kind_val);
728 { type_stack->push (tp_pointer); $$ = 0; }
730 { type_stack->push (tp_pointer); $$ = $2; }
732 { type_stack->push (tp_reference); $$ = 0; }
734 { type_stack->push (tp_reference); $$ = $2; }
738 direct_abs_decl: '(' abs_decl ')'
740 | '(' KIND '=' INT ')'
741 { push_kind_type ($4.val, $4.type); }
743 { push_kind_type ($2.val, $2.type); }
744 | direct_abs_decl func_mod
745 { type_stack->push (tp_function); }
747 { type_stack->push (tp_function); }
752 | '(' nonempty_typelist ')'
753 { free ($2); $$ = 0; }
756 typebase /* Implements (approximately): (type-qualifier)* type-specifier */
760 { $$ = parse_f_type (pstate)->builtin_integer; }
762 { $$ = parse_f_type (pstate)->builtin_integer_s2; }
764 { $$ = parse_f_type (pstate)->builtin_character; }
766 { $$ = parse_f_type (pstate)->builtin_logical_s8; }
768 { $$ = parse_f_type (pstate)->builtin_logical; }
770 { $$ = parse_f_type (pstate)->builtin_logical_s2; }
772 { $$ = parse_f_type (pstate)->builtin_logical_s1; }
774 { $$ = parse_f_type (pstate)->builtin_real; }
776 { $$ = parse_f_type (pstate)->builtin_real_s8; }
778 { $$ = parse_f_type (pstate)->builtin_real_s16; }
780 { $$ = parse_f_type (pstate)->builtin_complex_s8; }
782 { $$ = parse_f_type (pstate)->builtin_complex_s8; }
783 | COMPLEX_S16_KEYWORD
784 { $$ = parse_f_type (pstate)->builtin_complex_s16; }
785 | COMPLEX_S32_KEYWORD
786 { $$ = parse_f_type (pstate)->builtin_complex_s32; }
788 { $$ = parse_f_type (pstate)->builtin_real;}
790 { $$ = parse_f_type (pstate)->builtin_real_s8;}
791 | SINGLE COMPLEX_KEYWORD
792 { $$ = parse_f_type (pstate)->builtin_complex_s8;}
793 | DOUBLE COMPLEX_KEYWORD
794 { $$ = parse_f_type (pstate)->builtin_complex_s16;}
799 { $$ = (struct type **) malloc (sizeof (struct type *) * 2);
800 $<ivec>$[0] = 1; /* Number of types in vector */
803 | nonempty_typelist ',' type
804 { int len = sizeof (struct type *) * (++($<ivec>1[0]) + 1);
805 $$ = (struct type **) realloc ((char *) $1, len);
806 $$[$<ivec>$[0]] = $3;
814 name_not_typename : NAME
815 /* These would be useful if name_not_typename was useful, but it is just
816 a fake for "variable", so these cause reduce/reduce conflicts because
817 the parser can't tell whether NAME_OR_INT is a name_not_typename (=variable,
818 =exp) or just an exp. If name_not_typename was ever used in an lvalue
819 context where only a name could occur, this might be useful.
826 /* Take care of parsing a number (anything that starts with a digit).
827 Set yylval and return the token type; update lexptr.
828 LEN is the number of characters in it. */
830 /*** Needs some error checking for the float case ***/
833 parse_number (struct parser_state *par_state,
834 const char *p, int len, int parsed_float, YYSTYPE *putithere)
839 int base = input_radix;
843 struct type *signed_type;
844 struct type *unsigned_type;
848 /* It's a float since it contains a point or an exponent. */
849 /* [dD] is not understood as an exponent by parse_float,
854 for (tmp2 = tmp; *tmp2; ++tmp2)
855 if (*tmp2 == 'd' || *tmp2 == 'D')
858 /* FIXME: Should this use different types? */
859 putithere->typed_val_float.type = parse_f_type (pstate)->builtin_real_s8;
860 bool parsed = parse_float (tmp, len,
861 putithere->typed_val_float.type,
862 putithere->typed_val_float.val);
864 return parsed? FLOAT : ERROR;
867 /* Handle base-switching prefixes 0x, 0t, 0d, 0 */
903 if (len == 0 && c == 'l')
905 else if (len == 0 && c == 'u')
910 if (c >= '0' && c <= '9')
912 else if (c >= 'a' && c <= 'f')
915 return ERROR; /* Char not a digit */
917 return ERROR; /* Invalid digit in this base */
921 /* Portably test for overflow (only works for nonzero values, so make
922 a second check for zero). */
923 if ((prevn >= n) && n != 0)
924 unsigned_p=1; /* Try something unsigned */
925 /* If range checking enabled, portably test for unsigned overflow. */
926 if (RANGE_CHECK && n != 0)
928 if ((unsigned_p && (unsigned)prevn >= (unsigned)n))
929 range_error (_("Overflow on numeric constant."));
934 /* If the number is too big to be an int, or it's got an l suffix
935 then it's a long. Work out if this has to be a long by
936 shifting right and seeing if anything remains, and the
937 target int size is different to the target long size.
939 In the expression below, we could have tested
940 (n >> gdbarch_int_bit (parse_gdbarch))
941 to see if it was zero,
942 but too many compilers warn about that, when ints and longs
943 are the same size. So we shift it twice, with fewer bits
944 each time, for the same result. */
946 if ((gdbarch_int_bit (par_state->gdbarch ())
947 != gdbarch_long_bit (par_state->gdbarch ())
949 >> (gdbarch_int_bit (par_state->gdbarch ())-2))) /* Avoid
953 high_bit = ((ULONGEST)1)
954 << (gdbarch_long_bit (par_state->gdbarch ())-1);
955 unsigned_type = parse_type (par_state)->builtin_unsigned_long;
956 signed_type = parse_type (par_state)->builtin_long;
961 ((ULONGEST)1) << (gdbarch_int_bit (par_state->gdbarch ()) - 1);
962 unsigned_type = parse_type (par_state)->builtin_unsigned_int;
963 signed_type = parse_type (par_state)->builtin_int;
966 putithere->typed_val.val = n;
968 /* If the high bit of the worked out type is set then this number
969 has to be unsigned. */
971 if (unsigned_p || (n & high_bit))
972 putithere->typed_val.type = unsigned_type;
974 putithere->typed_val.type = signed_type;
979 /* Called to setup the type stack when we encounter a '(kind=N)' type
980 modifier, performs some bounds checking on 'N' and then pushes this to
981 the type stack followed by the 'tp_kind' marker. */
983 push_kind_type (LONGEST val, struct type *type)
987 if (type->is_unsigned ())
989 ULONGEST uval = static_cast <ULONGEST> (val);
991 error (_("kind value out of range"));
992 ival = static_cast <int> (uval);
996 if (val > INT_MAX || val < 0)
997 error (_("kind value out of range"));
998 ival = static_cast <int> (val);
1001 type_stack->push (ival);
1002 type_stack->push (tp_kind);
1005 /* Called when a type has a '(kind=N)' modifier after it, for example
1006 'character(kind=1)'. The BASETYPE is the type described by 'character'
1007 in our example, and KIND is the integer '1'. This function returns a
1008 new type that represents the basetype of a specific kind. */
1009 static struct type *
1010 convert_to_kind_type (struct type *basetype, int kind)
1012 if (basetype == parse_f_type (pstate)->builtin_character)
1014 /* Character of kind 1 is a special case, this is the same as the
1015 base character type. */
1017 return parse_f_type (pstate)->builtin_character;
1019 else if (basetype == parse_f_type (pstate)->builtin_complex_s8)
1022 return parse_f_type (pstate)->builtin_complex_s8;
1024 return parse_f_type (pstate)->builtin_complex_s16;
1025 else if (kind == 16)
1026 return parse_f_type (pstate)->builtin_complex_s32;
1028 else if (basetype == parse_f_type (pstate)->builtin_real)
1031 return parse_f_type (pstate)->builtin_real;
1033 return parse_f_type (pstate)->builtin_real_s8;
1034 else if (kind == 16)
1035 return parse_f_type (pstate)->builtin_real_s16;
1037 else if (basetype == parse_f_type (pstate)->builtin_logical)
1040 return parse_f_type (pstate)->builtin_logical_s1;
1042 return parse_f_type (pstate)->builtin_logical_s2;
1044 return parse_f_type (pstate)->builtin_logical;
1046 return parse_f_type (pstate)->builtin_logical_s8;
1048 else if (basetype == parse_f_type (pstate)->builtin_integer)
1051 return parse_f_type (pstate)->builtin_integer_s2;
1053 return parse_f_type (pstate)->builtin_integer;
1055 return parse_f_type (pstate)->builtin_integer_s8;
1058 error (_("unsupported kind %d for type %s"),
1059 kind, TYPE_SAFE_NAME (basetype));
1061 /* Should never get here. */
1067 /* The string to match against. */
1070 /* The lexer token to return. */
1073 /* The expression opcode to embed within the token. */
1074 enum exp_opcode opcode;
1076 /* When this is true the string in OPER is matched exactly including
1077 case, when this is false OPER is matched case insensitively. */
1078 bool case_sensitive;
1081 /* List of Fortran operators. */
1083 static const struct token fortran_operators[] =
1085 { ".and.", BOOL_AND, OP_NULL, false },
1086 { ".or.", BOOL_OR, OP_NULL, false },
1087 { ".not.", BOOL_NOT, OP_NULL, false },
1088 { ".eq.", EQUAL, OP_NULL, false },
1089 { ".eqv.", EQUAL, OP_NULL, false },
1090 { ".neqv.", NOTEQUAL, OP_NULL, false },
1091 { ".xor.", NOTEQUAL, OP_NULL, false },
1092 { "==", EQUAL, OP_NULL, false },
1093 { ".ne.", NOTEQUAL, OP_NULL, false },
1094 { "/=", NOTEQUAL, OP_NULL, false },
1095 { ".le.", LEQ, OP_NULL, false },
1096 { "<=", LEQ, OP_NULL, false },
1097 { ".ge.", GEQ, OP_NULL, false },
1098 { ">=", GEQ, OP_NULL, false },
1099 { ".gt.", GREATERTHAN, OP_NULL, false },
1100 { ">", GREATERTHAN, OP_NULL, false },
1101 { ".lt.", LESSTHAN, OP_NULL, false },
1102 { "<", LESSTHAN, OP_NULL, false },
1103 { "**", STARSTAR, BINOP_EXP, false },
1106 /* Holds the Fortran representation of a boolean, and the integer value we
1107 substitute in when one of the matching strings is parsed. */
1108 struct f77_boolean_val
1110 /* The string representing a Fortran boolean. */
1113 /* The integer value to replace it with. */
1117 /* The set of Fortran booleans. These are matched case insensitively. */
1118 static const struct f77_boolean_val boolean_values[] =
1124 static const struct token f77_keywords[] =
1126 /* Historically these have always been lowercase only in GDB. */
1127 { "complex_16", COMPLEX_S16_KEYWORD, OP_NULL, true },
1128 { "complex_32", COMPLEX_S32_KEYWORD, OP_NULL, true },
1129 { "character", CHARACTER, OP_NULL, true },
1130 { "integer_2", INT_S2_KEYWORD, OP_NULL, true },
1131 { "logical_1", LOGICAL_S1_KEYWORD, OP_NULL, true },
1132 { "logical_2", LOGICAL_S2_KEYWORD, OP_NULL, true },
1133 { "logical_8", LOGICAL_S8_KEYWORD, OP_NULL, true },
1134 { "complex_8", COMPLEX_S8_KEYWORD, OP_NULL, true },
1135 { "integer", INT_KEYWORD, OP_NULL, true },
1136 { "logical", LOGICAL_KEYWORD, OP_NULL, true },
1137 { "real_16", REAL_S16_KEYWORD, OP_NULL, true },
1138 { "complex", COMPLEX_KEYWORD, OP_NULL, true },
1139 { "sizeof", SIZEOF, OP_NULL, true },
1140 { "real_8", REAL_S8_KEYWORD, OP_NULL, true },
1141 { "real", REAL_KEYWORD, OP_NULL, true },
1142 { "single", SINGLE, OP_NULL, true },
1143 { "double", DOUBLE, OP_NULL, true },
1144 { "precision", PRECISION, OP_NULL, true },
1145 /* The following correspond to actual functions in Fortran and are case
1147 { "kind", KIND, OP_NULL, false },
1148 { "abs", UNOP_INTRINSIC, UNOP_ABS, false },
1149 { "mod", BINOP_INTRINSIC, BINOP_MOD, false },
1150 { "floor", UNOP_INTRINSIC, UNOP_FORTRAN_FLOOR, false },
1151 { "ceiling", UNOP_INTRINSIC, UNOP_FORTRAN_CEILING, false },
1152 { "modulo", BINOP_INTRINSIC, BINOP_FORTRAN_MODULO, false },
1153 { "cmplx", BINOP_INTRINSIC, BINOP_FORTRAN_CMPLX, false },
1154 { "lbound", UNOP_OR_BINOP_INTRINSIC, FORTRAN_LBOUND, false },
1155 { "ubound", UNOP_OR_BINOP_INTRINSIC, FORTRAN_UBOUND, false },
1156 { "allocated", UNOP_INTRINSIC, UNOP_FORTRAN_ALLOCATED, false },
1157 { "associated", UNOP_OR_BINOP_INTRINSIC, FORTRAN_ASSOCIATED, false },
1158 { "rank", UNOP_INTRINSIC, UNOP_FORTRAN_RANK, false },
1159 { "size", UNOP_OR_BINOP_INTRINSIC, FORTRAN_ARRAY_SIZE, false },
1160 { "shape", UNOP_INTRINSIC, UNOP_FORTRAN_SHAPE, false },
1161 { "loc", UNOP_INTRINSIC, UNOP_FORTRAN_LOC, false },
1164 /* Implementation of a dynamically expandable buffer for processing input
1165 characters acquired through lexptr and building a value to return in
1166 yylval. Ripped off from ch-exp.y */
1168 static char *tempbuf; /* Current buffer contents */
1169 static int tempbufsize; /* Size of allocated buffer */
1170 static int tempbufindex; /* Current index into buffer */
1172 #define GROWBY_MIN_SIZE 64 /* Minimum amount to grow buffer by */
1174 #define CHECKBUF(size) \
1176 if (tempbufindex + (size) >= tempbufsize) \
1178 growbuf_by_size (size); \
1183 /* Grow the static temp buffer if necessary, including allocating the
1184 first one on demand. */
1187 growbuf_by_size (int count)
1191 growby = std::max (count, GROWBY_MIN_SIZE);
1192 tempbufsize += growby;
1193 if (tempbuf == NULL)
1194 tempbuf = (char *) malloc (tempbufsize);
1196 tempbuf = (char *) realloc (tempbuf, tempbufsize);
1199 /* Blatantly ripped off from ch-exp.y. This routine recognizes F77
1202 Recognize a string literal. A string literal is a nonzero sequence
1203 of characters enclosed in matching single quotes, except that
1204 a single character inside single quotes is a character literal, which
1205 we reject as a string literal. To embed the terminator character inside
1206 a string, it is simply doubled (I.E. 'this''is''one''string') */
1209 match_string_literal (void)
1211 const char *tokptr = pstate->lexptr;
1213 for (tempbufindex = 0, tokptr++; *tokptr != '\0'; tokptr++)
1216 if (*tokptr == *pstate->lexptr)
1218 if (*(tokptr + 1) == *pstate->lexptr)
1223 tempbuf[tempbufindex++] = *tokptr;
1225 if (*tokptr == '\0' /* no terminator */
1226 || tempbufindex == 0) /* no string */
1230 tempbuf[tempbufindex] = '\0';
1231 yylval.sval.ptr = tempbuf;
1232 yylval.sval.length = tempbufindex;
1233 pstate->lexptr = ++tokptr;
1234 return STRING_LITERAL;
1238 /* This is set if a NAME token appeared at the very end of the input
1239 string, with no whitespace separating the name from the EOF. This
1240 is used only when parsing to do field name completion. */
1241 static bool saw_name_at_eof;
1243 /* This is set if the previously-returned token was a structure
1245 static bool last_was_structop;
1247 /* Read one token, getting characters through lexptr. */
1255 const char *tokstart;
1256 bool saw_structop = last_was_structop;
1258 last_was_structop = false;
1262 pstate->prev_lexptr = pstate->lexptr;
1264 tokstart = pstate->lexptr;
1266 /* First of all, let us make sure we are not dealing with the
1267 special tokens .true. and .false. which evaluate to 1 and 0. */
1269 if (*pstate->lexptr == '.')
1271 for (int i = 0; i < ARRAY_SIZE (boolean_values); i++)
1273 if (strncasecmp (tokstart, boolean_values[i].name,
1274 strlen (boolean_values[i].name)) == 0)
1276 pstate->lexptr += strlen (boolean_values[i].name);
1277 yylval.lval = boolean_values[i].value;
1278 return BOOLEAN_LITERAL;
1283 /* See if it is a Fortran operator. */
1284 for (int i = 0; i < ARRAY_SIZE (fortran_operators); i++)
1285 if (strncasecmp (tokstart, fortran_operators[i].oper,
1286 strlen (fortran_operators[i].oper)) == 0)
1288 gdb_assert (!fortran_operators[i].case_sensitive);
1289 pstate->lexptr += strlen (fortran_operators[i].oper);
1290 yylval.opcode = fortran_operators[i].opcode;
1291 return fortran_operators[i].token;
1294 switch (c = *tokstart)
1297 if (saw_name_at_eof)
1299 saw_name_at_eof = false;
1302 else if (pstate->parse_completion && saw_structop)
1313 token = match_string_literal ();
1324 if (paren_depth == 0)
1331 if (pstate->comma_terminates && paren_depth == 0)
1337 /* Might be a floating point number. */
1338 if (pstate->lexptr[1] < '0' || pstate->lexptr[1] > '9')
1339 goto symbol; /* Nope, must be a symbol. */
1353 /* It's a number. */
1354 int got_dot = 0, got_e = 0, got_d = 0, toktype;
1355 const char *p = tokstart;
1356 int hex = input_radix > 10;
1358 if (c == '0' && (p[1] == 'x' || p[1] == 'X'))
1363 else if (c == '0' && (p[1]=='t' || p[1]=='T'
1364 || p[1]=='d' || p[1]=='D'))
1372 if (!hex && !got_e && (*p == 'e' || *p == 'E'))
1373 got_dot = got_e = 1;
1374 else if (!hex && !got_d && (*p == 'd' || *p == 'D'))
1375 got_dot = got_d = 1;
1376 else if (!hex && !got_dot && *p == '.')
1378 else if (((got_e && (p[-1] == 'e' || p[-1] == 'E'))
1379 || (got_d && (p[-1] == 'd' || p[-1] == 'D')))
1380 && (*p == '-' || *p == '+'))
1381 /* This is the sign of the exponent, not the end of the
1384 /* We will take any letters or digits. parse_number will
1385 complain if past the radix, or if L or U are not final. */
1386 else if ((*p < '0' || *p > '9')
1387 && ((*p < 'a' || *p > 'z')
1388 && (*p < 'A' || *p > 'Z')))
1391 toktype = parse_number (pstate, tokstart, p - tokstart,
1392 got_dot|got_e|got_d,
1394 if (toktype == ERROR)
1396 char *err_copy = (char *) alloca (p - tokstart + 1);
1398 memcpy (err_copy, tokstart, p - tokstart);
1399 err_copy[p - tokstart] = 0;
1400 error (_("Invalid number \"%s\"."), err_copy);
1407 last_was_structop = true;
1433 if (!(c == '_' || c == '$' || c ==':'
1434 || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')))
1435 /* We must have come across a bad character (e.g. ';'). */
1436 error (_("Invalid character '%c' in expression."), c);
1439 for (c = tokstart[namelen];
1440 (c == '_' || c == '$' || c == ':' || (c >= '0' && c <= '9')
1441 || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'));
1442 c = tokstart[++namelen]);
1444 /* The token "if" terminates the expression and is NOT
1445 removed from the input stream. */
1447 if (namelen == 2 && tokstart[0] == 'i' && tokstart[1] == 'f')
1450 pstate->lexptr += namelen;
1452 /* Catch specific keywords. */
1454 for (int i = 0; i < ARRAY_SIZE (f77_keywords); i++)
1455 if (strlen (f77_keywords[i].oper) == namelen
1456 && ((!f77_keywords[i].case_sensitive
1457 && strncasecmp (tokstart, f77_keywords[i].oper, namelen) == 0)
1458 || (f77_keywords[i].case_sensitive
1459 && strncmp (tokstart, f77_keywords[i].oper, namelen) == 0)))
1461 yylval.opcode = f77_keywords[i].opcode;
1462 return f77_keywords[i].token;
1465 yylval.sval.ptr = tokstart;
1466 yylval.sval.length = namelen;
1468 if (*tokstart == '$')
1469 return DOLLAR_VARIABLE;
1471 /* Use token-type TYPENAME for symbols that happen to be defined
1472 currently as names of types; NAME for other symbols.
1473 The caller is not constrained to care about the distinction. */
1475 std::string tmp = copy_name (yylval.sval);
1476 struct block_symbol result;
1477 enum domain_enum_tag lookup_domains[] =
1485 for (int i = 0; i < ARRAY_SIZE (lookup_domains); ++i)
1487 result = lookup_symbol (tmp.c_str (), pstate->expression_context_block,
1488 lookup_domains[i], NULL);
1489 if (result.symbol && SYMBOL_CLASS (result.symbol) == LOC_TYPEDEF)
1491 yylval.tsym.type = SYMBOL_TYPE (result.symbol);
1500 = language_lookup_primitive_type (pstate->language (),
1501 pstate->gdbarch (), tmp.c_str ());
1502 if (yylval.tsym.type != NULL)
1505 /* Input names that aren't symbols but ARE valid hex numbers,
1506 when the input radix permits them, can be names or numbers
1507 depending on the parse. Note we support radixes > 16 here. */
1509 && ((tokstart[0] >= 'a' && tokstart[0] < 'a' + input_radix - 10)
1510 || (tokstart[0] >= 'A' && tokstart[0] < 'A' + input_radix - 10)))
1512 YYSTYPE newlval; /* Its value is ignored. */
1513 hextype = parse_number (pstate, tokstart, namelen, 0, &newlval);
1516 yylval.ssym.sym = result;
1517 yylval.ssym.is_a_field_of_this = false;
1522 if (pstate->parse_completion && *pstate->lexptr == '\0')
1523 saw_name_at_eof = true;
1525 /* Any other kind of symbol */
1526 yylval.ssym.sym = result;
1527 yylval.ssym.is_a_field_of_this = false;
1533 f_language::parser (struct parser_state *par_state) const
1535 /* Setting up the parser state. */
1536 scoped_restore pstate_restore = make_scoped_restore (&pstate);
1537 scoped_restore restore_yydebug = make_scoped_restore (&yydebug,
1539 gdb_assert (par_state != NULL);
1541 last_was_structop = false;
1542 saw_name_at_eof = false;
1545 struct type_stack stack;
1546 scoped_restore restore_type_stack = make_scoped_restore (&type_stack,
1549 int result = yyparse ();
1551 pstate->set_operation (pstate->pop ());
1556 yyerror (const char *msg)
1558 if (pstate->prev_lexptr)
1559 pstate->lexptr = pstate->prev_lexptr;
1561 error (_("A %s in expression, near `%s'."), msg, pstate->lexptr);