2 /* YACC parser for Fortran expressions, for GDB.
3 Copyright (C) 1986-2023 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);
93 static void wrap_unop_intrinsic (exp_opcode opcode);
95 static void wrap_binop_intrinsic (exp_opcode opcode);
97 static void wrap_ternop_intrinsic (exp_opcode opcode);
100 static void fortran_wrap2_kind (type *base_type);
103 static void fortran_wrap3_kind (type *base_type);
105 using namespace expr;
108 /* Although the yacc "value" of an expression is not used,
109 since the result is stored in the structure being created,
110 other node types do have values. */
127 struct symtoken ssym;
129 enum exp_opcode opcode;
130 struct internalvar *ivar;
137 /* YYSTYPE gets defined by %union */
138 static int parse_number (struct parser_state *, const char *, int,
142 %type <voidval> exp type_exp start variable
143 %type <tval> type typebase
144 %type <tvec> nonempty_typelist
145 /* %type <bval> block */
147 /* Fancy type parsing. */
148 %type <voidval> func_mod direct_abs_decl abs_decl
151 %token <typed_val> INT
152 %token <typed_val_float> FLOAT
154 /* Both NAME and TYPENAME tokens represent symbols in the input,
155 and both convey their data as strings.
156 But a TYPENAME is a string that happens to be defined as a typedef
157 or builtin type name (such as int or char)
158 and a NAME is any other symbol.
159 Contexts where this distinction is not important can use the
160 nonterminal "name", which matches either NAME or TYPENAME. */
162 %token <sval> STRING_LITERAL
163 %token <lval> BOOLEAN_LITERAL
165 %token <tsym> TYPENAME
166 %token <voidval> COMPLETE
168 %type <ssym> name_not_typename
170 /* A NAME_OR_INT is a symbol which is not known in the symbol table,
171 but which would parse as a valid number in the current input radix.
172 E.g. "c" when input_radix==16. Depending on the parse, it will be
173 turned into a name or into a number. */
175 %token <ssym> NAME_OR_INT
180 /* Special type cases, put in to allow the parser to distinguish different
182 %token INT_S1_KEYWORD INT_S2_KEYWORD INT_KEYWORD INT_S4_KEYWORD INT_S8_KEYWORD
183 %token LOGICAL_S1_KEYWORD LOGICAL_S2_KEYWORD LOGICAL_KEYWORD LOGICAL_S4_KEYWORD
184 %token LOGICAL_S8_KEYWORD
185 %token REAL_KEYWORD REAL_S4_KEYWORD REAL_S8_KEYWORD REAL_S16_KEYWORD
186 %token COMPLEX_KEYWORD COMPLEX_S4_KEYWORD COMPLEX_S8_KEYWORD
187 %token COMPLEX_S16_KEYWORD
188 %token BOOL_AND BOOL_OR BOOL_NOT
189 %token SINGLE DOUBLE PRECISION
190 %token <lval> CHARACTER
192 %token <sval> DOLLAR_VARIABLE
194 %token <opcode> ASSIGN_MODIFY
195 %token <opcode> UNOP_INTRINSIC BINOP_INTRINSIC
196 %token <opcode> UNOP_OR_BINOP_INTRINSIC UNOP_OR_BINOP_OR_TERNOP_INTRINSIC
200 %right '=' ASSIGN_MODIFY
209 %left LESSTHAN GREATERTHAN LEQ GEQ
227 { pstate->push_new<type_operation> ($1); }
234 /* Expressions, not including the comma operator. */
235 exp : '*' exp %prec UNARY
236 { pstate->wrap<unop_ind_operation> (); }
239 exp : '&' exp %prec UNARY
240 { pstate->wrap<unop_addr_operation> (); }
243 exp : '-' exp %prec UNARY
244 { pstate->wrap<unary_neg_operation> (); }
247 exp : BOOL_NOT exp %prec UNARY
248 { pstate->wrap<unary_logical_not_operation> (); }
251 exp : '~' exp %prec UNARY
252 { pstate->wrap<unary_complement_operation> (); }
255 exp : SIZEOF exp %prec UNARY
256 { pstate->wrap<unop_sizeof_operation> (); }
259 exp : KIND '(' exp ')' %prec UNARY
260 { pstate->wrap<fortran_kind_operation> (); }
263 /* No more explicit array operators, we treat everything in F77 as
264 a function call. The disambiguation as to whether we are
265 doing a subscript operation or a function call is done
269 { pstate->start_arglist (); }
272 std::vector<operation_up> args
273 = pstate->pop_vector (pstate->end_arglist ());
274 pstate->push_new<fortran_undetermined>
275 (pstate->pop (), std::move (args));
279 exp : UNOP_INTRINSIC '(' exp ')'
281 wrap_unop_intrinsic ($1);
285 exp : BINOP_INTRINSIC '(' exp ',' exp ')'
287 wrap_binop_intrinsic ($1);
291 exp : UNOP_OR_BINOP_INTRINSIC '('
292 { pstate->start_arglist (); }
295 const int n = pstate->end_arglist ();
300 wrap_unop_intrinsic ($1);
303 wrap_binop_intrinsic ($1);
306 gdb_assert_not_reached
307 ("wrong number of arguments for intrinsics");
311 exp : UNOP_OR_BINOP_OR_TERNOP_INTRINSIC '('
312 { pstate->start_arglist (); }
315 const int n = pstate->end_arglist ();
320 wrap_unop_intrinsic ($1);
323 wrap_binop_intrinsic ($1);
326 wrap_ternop_intrinsic ($1);
329 gdb_assert_not_reached
330 ("wrong number of arguments for intrinsics");
339 { pstate->arglist_len = 1; }
343 { pstate->arglist_len = 1; }
346 arglist : arglist ',' exp %prec ABOVE_COMMA
347 { pstate->arglist_len++; }
350 arglist : arglist ',' subrange %prec ABOVE_COMMA
351 { pstate->arglist_len++; }
354 /* There are four sorts of subrange types in F90. */
356 subrange: exp ':' exp %prec ABOVE_COMMA
358 operation_up high = pstate->pop ();
359 operation_up low = pstate->pop ();
360 pstate->push_new<fortran_range_operation>
361 (RANGE_STANDARD, std::move (low),
362 std::move (high), operation_up ());
366 subrange: exp ':' %prec ABOVE_COMMA
368 operation_up low = pstate->pop ();
369 pstate->push_new<fortran_range_operation>
370 (RANGE_HIGH_BOUND_DEFAULT, std::move (low),
371 operation_up (), operation_up ());
375 subrange: ':' exp %prec ABOVE_COMMA
377 operation_up high = pstate->pop ();
378 pstate->push_new<fortran_range_operation>
379 (RANGE_LOW_BOUND_DEFAULT, operation_up (),
380 std::move (high), operation_up ());
384 subrange: ':' %prec ABOVE_COMMA
386 pstate->push_new<fortran_range_operation>
387 (RANGE_LOW_BOUND_DEFAULT
388 | RANGE_HIGH_BOUND_DEFAULT,
389 operation_up (), operation_up (),
394 /* And each of the four subrange types can also have a stride. */
395 subrange: exp ':' exp ':' exp %prec ABOVE_COMMA
397 operation_up stride = pstate->pop ();
398 operation_up high = pstate->pop ();
399 operation_up low = pstate->pop ();
400 pstate->push_new<fortran_range_operation>
401 (RANGE_STANDARD | RANGE_HAS_STRIDE,
402 std::move (low), std::move (high),
407 subrange: exp ':' ':' exp %prec ABOVE_COMMA
409 operation_up stride = pstate->pop ();
410 operation_up low = pstate->pop ();
411 pstate->push_new<fortran_range_operation>
412 (RANGE_HIGH_BOUND_DEFAULT
414 std::move (low), operation_up (),
419 subrange: ':' exp ':' exp %prec ABOVE_COMMA
421 operation_up stride = pstate->pop ();
422 operation_up high = pstate->pop ();
423 pstate->push_new<fortran_range_operation>
424 (RANGE_LOW_BOUND_DEFAULT
426 operation_up (), std::move (high),
431 subrange: ':' ':' exp %prec ABOVE_COMMA
433 operation_up stride = pstate->pop ();
434 pstate->push_new<fortran_range_operation>
435 (RANGE_LOW_BOUND_DEFAULT
436 | RANGE_HIGH_BOUND_DEFAULT
438 operation_up (), operation_up (),
443 complexnum: exp ',' exp
447 exp : '(' complexnum ')'
449 operation_up rhs = pstate->pop ();
450 operation_up lhs = pstate->pop ();
451 pstate->push_new<complex_operation>
452 (std::move (lhs), std::move (rhs),
453 parse_f_type (pstate)->builtin_complex_s16);
457 exp : '(' type ')' exp %prec UNARY
459 pstate->push_new<unop_cast_operation>
460 (pstate->pop (), $2);
466 pstate->push_new<fortran_structop_operation>
467 (pstate->pop (), copy_name ($3));
471 exp : exp '%' name COMPLETE
473 structop_base_operation *op
474 = new fortran_structop_operation (pstate->pop (),
476 pstate->mark_struct_expression (op);
477 pstate->push (operation_up (op));
481 exp : exp '%' COMPLETE
483 structop_base_operation *op
484 = new fortran_structop_operation (pstate->pop (),
486 pstate->mark_struct_expression (op);
487 pstate->push (operation_up (op));
491 /* Binary operators in order of decreasing precedence. */
494 { pstate->wrap2<repeat_operation> (); }
497 exp : exp STARSTAR exp
498 { pstate->wrap2<exp_operation> (); }
502 { pstate->wrap2<mul_operation> (); }
506 { pstate->wrap2<div_operation> (); }
510 { pstate->wrap2<add_operation> (); }
514 { pstate->wrap2<sub_operation> (); }
518 { pstate->wrap2<lsh_operation> (); }
522 { pstate->wrap2<rsh_operation> (); }
526 { pstate->wrap2<equal_operation> (); }
529 exp : exp NOTEQUAL exp
530 { pstate->wrap2<notequal_operation> (); }
534 { pstate->wrap2<leq_operation> (); }
538 { pstate->wrap2<geq_operation> (); }
541 exp : exp LESSTHAN exp
542 { pstate->wrap2<less_operation> (); }
545 exp : exp GREATERTHAN exp
546 { pstate->wrap2<gtr_operation> (); }
550 { pstate->wrap2<bitwise_and_operation> (); }
554 { pstate->wrap2<bitwise_xor_operation> (); }
558 { pstate->wrap2<bitwise_ior_operation> (); }
561 exp : exp BOOL_AND exp
562 { pstate->wrap2<logical_and_operation> (); }
566 exp : exp BOOL_OR exp
567 { pstate->wrap2<logical_or_operation> (); }
571 { pstate->wrap2<assign_operation> (); }
574 exp : exp ASSIGN_MODIFY exp
576 operation_up rhs = pstate->pop ();
577 operation_up lhs = pstate->pop ();
578 pstate->push_new<assign_modify_operation>
579 ($2, std::move (lhs), std::move (rhs));
585 pstate->push_new<long_const_operation>
592 parse_number (pstate, $1.stoken.ptr,
593 $1.stoken.length, 0, &val);
594 pstate->push_new<long_const_operation>
603 std::copy (std::begin ($1.val), std::end ($1.val),
605 pstate->push_new<float_const_operation> ($1.type, data);
612 exp : DOLLAR_VARIABLE
613 { pstate->push_dollar ($1); }
616 exp : SIZEOF '(' type ')' %prec UNARY
618 $3 = check_typedef ($3);
619 pstate->push_new<long_const_operation>
620 (parse_f_type (pstate)->builtin_integer,
625 exp : BOOLEAN_LITERAL
626 { pstate->push_new<bool_operation> ($1); }
631 pstate->push_new<string_operation>
636 variable: name_not_typename
637 { struct block_symbol sym = $1.sym;
638 std::string name = copy_name ($1.stoken);
639 pstate->push_symbol (name.c_str (), sym);
650 /* This is where the interesting stuff happens. */
653 struct type *follow_type = $1;
654 struct type *range_type;
657 switch (type_stack->pop ())
663 follow_type = lookup_pointer_type (follow_type);
666 follow_type = lookup_lvalue_reference_type (follow_type);
669 array_size = type_stack->pop_int ();
670 if (array_size != -1)
672 struct type *idx_type
673 = parse_f_type (pstate)->builtin_integer;
674 type_allocator alloc (idx_type);
676 create_static_range_type (alloc, idx_type,
678 follow_type = create_array_type (alloc,
683 follow_type = lookup_pointer_type (follow_type);
686 follow_type = lookup_function_type (follow_type);
690 int kind_val = type_stack->pop_int ();
692 = convert_to_kind_type (follow_type, kind_val);
701 { type_stack->push (tp_pointer); $$ = 0; }
703 { type_stack->push (tp_pointer); $$ = $2; }
705 { type_stack->push (tp_reference); $$ = 0; }
707 { type_stack->push (tp_reference); $$ = $2; }
711 direct_abs_decl: '(' abs_decl ')'
713 | '(' KIND '=' INT ')'
714 { push_kind_type ($4.val, $4.type); }
716 { push_kind_type ($2.val, $2.type); }
717 | direct_abs_decl func_mod
718 { type_stack->push (tp_function); }
720 { type_stack->push (tp_function); }
725 | '(' nonempty_typelist ')'
726 { free ($2); $$ = 0; }
729 typebase /* Implements (approximately): (type-qualifier)* type-specifier */
733 { $$ = parse_f_type (pstate)->builtin_integer_s1; }
735 { $$ = parse_f_type (pstate)->builtin_integer_s2; }
737 { $$ = parse_f_type (pstate)->builtin_integer; }
739 { $$ = parse_f_type (pstate)->builtin_integer; }
741 { $$ = parse_f_type (pstate)->builtin_integer_s8; }
743 { $$ = parse_f_type (pstate)->builtin_character; }
745 { $$ = parse_f_type (pstate)->builtin_logical_s1; }
747 { $$ = parse_f_type (pstate)->builtin_logical_s2; }
749 { $$ = parse_f_type (pstate)->builtin_logical; }
751 { $$ = parse_f_type (pstate)->builtin_logical; }
753 { $$ = parse_f_type (pstate)->builtin_logical_s8; }
755 { $$ = parse_f_type (pstate)->builtin_real; }
757 { $$ = parse_f_type (pstate)->builtin_real; }
759 { $$ = parse_f_type (pstate)->builtin_real_s8; }
761 { $$ = parse_f_type (pstate)->builtin_real_s16; }
763 { $$ = parse_f_type (pstate)->builtin_complex; }
765 { $$ = parse_f_type (pstate)->builtin_complex; }
767 { $$ = parse_f_type (pstate)->builtin_complex_s8; }
768 | COMPLEX_S16_KEYWORD
769 { $$ = parse_f_type (pstate)->builtin_complex_s16; }
771 { $$ = parse_f_type (pstate)->builtin_real;}
773 { $$ = parse_f_type (pstate)->builtin_real_s8;}
774 | SINGLE COMPLEX_KEYWORD
775 { $$ = parse_f_type (pstate)->builtin_complex;}
776 | DOUBLE COMPLEX_KEYWORD
777 { $$ = parse_f_type (pstate)->builtin_complex_s8;}
782 { $$ = (struct type **) malloc (sizeof (struct type *) * 2);
783 $<ivec>$[0] = 1; /* Number of types in vector */
786 | nonempty_typelist ',' type
787 { int len = sizeof (struct type *) * (++($<ivec>1[0]) + 1);
788 $$ = (struct type **) realloc ((char *) $1, len);
789 $$[$<ivec>$[0]] = $3;
800 name_not_typename : NAME
801 /* These would be useful if name_not_typename was useful, but it is just
802 a fake for "variable", so these cause reduce/reduce conflicts because
803 the parser can't tell whether NAME_OR_INT is a name_not_typename (=variable,
804 =exp) or just an exp. If name_not_typename was ever used in an lvalue
805 context where only a name could occur, this might be useful.
812 /* Called to match intrinsic function calls with one argument to their
813 respective implementation and push the operation. */
816 wrap_unop_intrinsic (exp_opcode code)
821 pstate->wrap<fortran_abs_operation> ();
824 pstate->wrap<fortran_floor_operation_1arg> ();
826 case FORTRAN_CEILING:
827 pstate->wrap<fortran_ceil_operation_1arg> ();
829 case UNOP_FORTRAN_ALLOCATED:
830 pstate->wrap<fortran_allocated_operation> ();
832 case UNOP_FORTRAN_RANK:
833 pstate->wrap<fortran_rank_operation> ();
835 case UNOP_FORTRAN_SHAPE:
836 pstate->wrap<fortran_array_shape_operation> ();
838 case UNOP_FORTRAN_LOC:
839 pstate->wrap<fortran_loc_operation> ();
841 case FORTRAN_ASSOCIATED:
842 pstate->wrap<fortran_associated_1arg> ();
844 case FORTRAN_ARRAY_SIZE:
845 pstate->wrap<fortran_array_size_1arg> ();
848 pstate->wrap<fortran_cmplx_operation_1arg> ();
852 pstate->push_new<fortran_bound_1arg> (code, pstate->pop ());
855 gdb_assert_not_reached ("unhandled intrinsic");
859 /* Called to match intrinsic function calls with two arguments to their
860 respective implementation and push the operation. */
863 wrap_binop_intrinsic (exp_opcode code)
868 fortran_wrap2_kind<fortran_floor_operation_2arg>
869 (parse_f_type (pstate)->builtin_integer);
871 case FORTRAN_CEILING:
872 fortran_wrap2_kind<fortran_ceil_operation_2arg>
873 (parse_f_type (pstate)->builtin_integer);
876 pstate->wrap2<fortran_mod_operation> ();
878 case BINOP_FORTRAN_MODULO:
879 pstate->wrap2<fortran_modulo_operation> ();
882 pstate->wrap2<fortran_cmplx_operation_2arg> ();
884 case FORTRAN_ASSOCIATED:
885 pstate->wrap2<fortran_associated_2arg> ();
887 case FORTRAN_ARRAY_SIZE:
888 pstate->wrap2<fortran_array_size_2arg> ();
893 operation_up arg2 = pstate->pop ();
894 operation_up arg1 = pstate->pop ();
895 pstate->push_new<fortran_bound_2arg> (code, std::move (arg1),
900 gdb_assert_not_reached ("unhandled intrinsic");
904 /* Called to match intrinsic function calls with three arguments to their
905 respective implementation and push the operation. */
908 wrap_ternop_intrinsic (exp_opcode code)
915 operation_up kind_arg = pstate->pop ();
916 operation_up arg2 = pstate->pop ();
917 operation_up arg1 = pstate->pop ();
919 value *val = kind_arg->evaluate (nullptr, pstate->expout.get (),
920 EVAL_AVOID_SIDE_EFFECTS);
921 gdb_assert (val != nullptr);
924 = convert_to_kind_type (parse_f_type (pstate)->builtin_integer,
925 value_as_long (val));
927 pstate->push_new<fortran_bound_3arg> (code, std::move (arg1),
928 std::move (arg2), follow_type);
931 case FORTRAN_ARRAY_SIZE:
932 fortran_wrap3_kind<fortran_array_size_3arg>
933 (parse_f_type (pstate)->builtin_integer);
936 fortran_wrap3_kind<fortran_cmplx_operation_3arg>
937 (parse_f_type (pstate)->builtin_complex);
940 gdb_assert_not_reached ("unhandled intrinsic");
944 /* A helper that pops two operations (similar to wrap2), evaluates the last one
945 assuming it is a kind parameter, and wraps them in some other operation
946 pushing it to the stack. */
950 fortran_wrap2_kind (type *base_type)
952 operation_up kind_arg = pstate->pop ();
953 operation_up arg = pstate->pop ();
955 value *val = kind_arg->evaluate (nullptr, pstate->expout.get (),
956 EVAL_AVOID_SIDE_EFFECTS);
957 gdb_assert (val != nullptr);
959 type *follow_type = convert_to_kind_type (base_type, value_as_long (val));
961 pstate->push_new<T> (std::move (arg), follow_type);
964 /* A helper that pops three operations, evaluates the last one assuming it is a
965 kind parameter, and wraps them in some other operation pushing it to the
970 fortran_wrap3_kind (type *base_type)
972 operation_up kind_arg = pstate->pop ();
973 operation_up arg2 = pstate->pop ();
974 operation_up arg1 = pstate->pop ();
976 value *val = kind_arg->evaluate (nullptr, pstate->expout.get (),
977 EVAL_AVOID_SIDE_EFFECTS);
978 gdb_assert (val != nullptr);
980 type *follow_type = convert_to_kind_type (base_type, value_as_long (val));
982 pstate->push_new<T> (std::move (arg1), std::move (arg2), follow_type);
985 /* Take care of parsing a number (anything that starts with a digit).
986 Set yylval and return the token type; update lexptr.
987 LEN is the number of characters in it. */
989 /*** Needs some error checking for the float case ***/
992 parse_number (struct parser_state *par_state,
993 const char *p, int len, int parsed_float, YYSTYPE *putithere)
998 int base = input_radix;
1002 struct type *signed_type;
1003 struct type *unsigned_type;
1007 /* It's a float since it contains a point or an exponent. */
1008 /* [dD] is not understood as an exponent by parse_float,
1009 change it to 'e'. */
1013 for (tmp2 = tmp; *tmp2; ++tmp2)
1014 if (*tmp2 == 'd' || *tmp2 == 'D')
1017 /* FIXME: Should this use different types? */
1018 putithere->typed_val_float.type = parse_f_type (pstate)->builtin_real_s8;
1019 bool parsed = parse_float (tmp, len,
1020 putithere->typed_val_float.type,
1021 putithere->typed_val_float.val);
1023 return parsed? FLOAT : ERROR;
1026 /* Handle base-switching prefixes 0x, 0t, 0d, 0 */
1027 if (p[0] == '0' && len > 1)
1062 if (len == 0 && c == 'l')
1064 else if (len == 0 && c == 'u')
1069 if (c >= '0' && c <= '9')
1071 else if (c >= 'a' && c <= 'f')
1074 return ERROR; /* Char not a digit */
1076 return ERROR; /* Invalid digit in this base */
1080 /* Test for overflow. */
1081 if (prevn == 0 && n == 0)
1083 else if (RANGE_CHECK && prevn >= n)
1084 range_error (_("Overflow on numeric constant."));
1088 /* If the number is too big to be an int, or it's got an l suffix
1089 then it's a long. Work out if this has to be a long by
1090 shifting right and seeing if anything remains, and the
1091 target int size is different to the target long size.
1093 In the expression below, we could have tested
1094 (n >> gdbarch_int_bit (parse_gdbarch))
1095 to see if it was zero,
1096 but too many compilers warn about that, when ints and longs
1097 are the same size. So we shift it twice, with fewer bits
1098 each time, for the same result. */
1101 if ((gdbarch_int_bit (par_state->gdbarch ())
1102 != gdbarch_long_bit (par_state->gdbarch ())
1104 >> (gdbarch_int_bit (par_state->gdbarch ())-2))) /* Avoid
1108 bits_available = gdbarch_long_bit (par_state->gdbarch ());
1109 unsigned_type = parse_type (par_state)->builtin_unsigned_long;
1110 signed_type = parse_type (par_state)->builtin_long;
1114 bits_available = gdbarch_int_bit (par_state->gdbarch ());
1115 unsigned_type = parse_type (par_state)->builtin_unsigned_int;
1116 signed_type = parse_type (par_state)->builtin_int;
1118 high_bit = ((ULONGEST)1) << (bits_available - 1);
1121 && ((n >> 2) >> (bits_available - 2)))
1122 range_error (_("Overflow on numeric constant."));
1124 putithere->typed_val.val = n;
1126 /* If the high bit of the worked out type is set then this number
1127 has to be unsigned. */
1129 if (unsigned_p || (n & high_bit))
1130 putithere->typed_val.type = unsigned_type;
1132 putithere->typed_val.type = signed_type;
1137 /* Called to setup the type stack when we encounter a '(kind=N)' type
1138 modifier, performs some bounds checking on 'N' and then pushes this to
1139 the type stack followed by the 'tp_kind' marker. */
1141 push_kind_type (LONGEST val, struct type *type)
1145 if (type->is_unsigned ())
1147 ULONGEST uval = static_cast <ULONGEST> (val);
1149 error (_("kind value out of range"));
1150 ival = static_cast <int> (uval);
1154 if (val > INT_MAX || val < 0)
1155 error (_("kind value out of range"));
1156 ival = static_cast <int> (val);
1159 type_stack->push (ival);
1160 type_stack->push (tp_kind);
1163 /* Called when a type has a '(kind=N)' modifier after it, for example
1164 'character(kind=1)'. The BASETYPE is the type described by 'character'
1165 in our example, and KIND is the integer '1'. This function returns a
1166 new type that represents the basetype of a specific kind. */
1167 static struct type *
1168 convert_to_kind_type (struct type *basetype, int kind)
1170 if (basetype == parse_f_type (pstate)->builtin_character)
1172 /* Character of kind 1 is a special case, this is the same as the
1173 base character type. */
1175 return parse_f_type (pstate)->builtin_character;
1177 else if (basetype == parse_f_type (pstate)->builtin_complex)
1180 return parse_f_type (pstate)->builtin_complex;
1182 return parse_f_type (pstate)->builtin_complex_s8;
1183 else if (kind == 16)
1184 return parse_f_type (pstate)->builtin_complex_s16;
1186 else if (basetype == parse_f_type (pstate)->builtin_real)
1189 return parse_f_type (pstate)->builtin_real;
1191 return parse_f_type (pstate)->builtin_real_s8;
1192 else if (kind == 16)
1193 return parse_f_type (pstate)->builtin_real_s16;
1195 else if (basetype == parse_f_type (pstate)->builtin_logical)
1198 return parse_f_type (pstate)->builtin_logical_s1;
1200 return parse_f_type (pstate)->builtin_logical_s2;
1202 return parse_f_type (pstate)->builtin_logical;
1204 return parse_f_type (pstate)->builtin_logical_s8;
1206 else if (basetype == parse_f_type (pstate)->builtin_integer)
1209 return parse_f_type (pstate)->builtin_integer_s1;
1211 return parse_f_type (pstate)->builtin_integer_s2;
1213 return parse_f_type (pstate)->builtin_integer;
1215 return parse_f_type (pstate)->builtin_integer_s8;
1218 error (_("unsupported kind %d for type %s"),
1219 kind, TYPE_SAFE_NAME (basetype));
1221 /* Should never get here. */
1227 /* The string to match against. */
1230 /* The lexer token to return. */
1233 /* The expression opcode to embed within the token. */
1234 enum exp_opcode opcode;
1236 /* When this is true the string in OPER is matched exactly including
1237 case, when this is false OPER is matched case insensitively. */
1238 bool case_sensitive;
1241 /* List of Fortran operators. */
1243 static const struct token fortran_operators[] =
1245 { ".and.", BOOL_AND, OP_NULL, false },
1246 { ".or.", BOOL_OR, OP_NULL, false },
1247 { ".not.", BOOL_NOT, OP_NULL, false },
1248 { ".eq.", EQUAL, OP_NULL, false },
1249 { ".eqv.", EQUAL, OP_NULL, false },
1250 { ".neqv.", NOTEQUAL, OP_NULL, false },
1251 { ".xor.", NOTEQUAL, OP_NULL, false },
1252 { "==", EQUAL, OP_NULL, false },
1253 { ".ne.", NOTEQUAL, OP_NULL, false },
1254 { "/=", NOTEQUAL, OP_NULL, false },
1255 { ".le.", LEQ, OP_NULL, false },
1256 { "<=", LEQ, OP_NULL, false },
1257 { ".ge.", GEQ, OP_NULL, false },
1258 { ">=", GEQ, OP_NULL, false },
1259 { ".gt.", GREATERTHAN, OP_NULL, false },
1260 { ">", GREATERTHAN, OP_NULL, false },
1261 { ".lt.", LESSTHAN, OP_NULL, false },
1262 { "<", LESSTHAN, OP_NULL, false },
1263 { "**", STARSTAR, BINOP_EXP, false },
1266 /* Holds the Fortran representation of a boolean, and the integer value we
1267 substitute in when one of the matching strings is parsed. */
1268 struct f77_boolean_val
1270 /* The string representing a Fortran boolean. */
1273 /* The integer value to replace it with. */
1277 /* The set of Fortran booleans. These are matched case insensitively. */
1278 static const struct f77_boolean_val boolean_values[] =
1284 static const token f_keywords[] =
1286 /* Historically these have always been lowercase only in GDB. */
1287 { "character", CHARACTER, OP_NULL, true },
1288 { "complex", COMPLEX_KEYWORD, OP_NULL, true },
1289 { "complex_4", COMPLEX_S4_KEYWORD, OP_NULL, true },
1290 { "complex_8", COMPLEX_S8_KEYWORD, OP_NULL, true },
1291 { "complex_16", COMPLEX_S16_KEYWORD, OP_NULL, true },
1292 { "integer_1", INT_S1_KEYWORD, OP_NULL, true },
1293 { "integer_2", INT_S2_KEYWORD, OP_NULL, true },
1294 { "integer_4", INT_S4_KEYWORD, OP_NULL, true },
1295 { "integer", INT_KEYWORD, OP_NULL, true },
1296 { "integer_8", INT_S8_KEYWORD, OP_NULL, true },
1297 { "logical_1", LOGICAL_S1_KEYWORD, OP_NULL, true },
1298 { "logical_2", LOGICAL_S2_KEYWORD, OP_NULL, true },
1299 { "logical", LOGICAL_KEYWORD, OP_NULL, true },
1300 { "logical_4", LOGICAL_S4_KEYWORD, OP_NULL, true },
1301 { "logical_8", LOGICAL_S8_KEYWORD, OP_NULL, true },
1302 { "real", REAL_KEYWORD, OP_NULL, true },
1303 { "real_4", REAL_S4_KEYWORD, OP_NULL, true },
1304 { "real_8", REAL_S8_KEYWORD, OP_NULL, true },
1305 { "real_16", REAL_S16_KEYWORD, OP_NULL, true },
1306 { "sizeof", SIZEOF, OP_NULL, true },
1307 { "single", SINGLE, OP_NULL, true },
1308 { "double", DOUBLE, OP_NULL, true },
1309 { "precision", PRECISION, OP_NULL, true },
1310 /* The following correspond to actual functions in Fortran and are case
1312 { "kind", KIND, OP_NULL, false },
1313 { "abs", UNOP_INTRINSIC, UNOP_ABS, false },
1314 { "mod", BINOP_INTRINSIC, BINOP_MOD, false },
1315 { "floor", UNOP_OR_BINOP_INTRINSIC, FORTRAN_FLOOR, false },
1316 { "ceiling", UNOP_OR_BINOP_INTRINSIC, FORTRAN_CEILING, false },
1317 { "modulo", BINOP_INTRINSIC, BINOP_FORTRAN_MODULO, false },
1318 { "cmplx", UNOP_OR_BINOP_OR_TERNOP_INTRINSIC, FORTRAN_CMPLX, false },
1319 { "lbound", UNOP_OR_BINOP_OR_TERNOP_INTRINSIC, FORTRAN_LBOUND, false },
1320 { "ubound", UNOP_OR_BINOP_OR_TERNOP_INTRINSIC, FORTRAN_UBOUND, false },
1321 { "allocated", UNOP_INTRINSIC, UNOP_FORTRAN_ALLOCATED, false },
1322 { "associated", UNOP_OR_BINOP_INTRINSIC, FORTRAN_ASSOCIATED, false },
1323 { "rank", UNOP_INTRINSIC, UNOP_FORTRAN_RANK, false },
1324 { "size", UNOP_OR_BINOP_OR_TERNOP_INTRINSIC, FORTRAN_ARRAY_SIZE, false },
1325 { "shape", UNOP_INTRINSIC, UNOP_FORTRAN_SHAPE, false },
1326 { "loc", UNOP_INTRINSIC, UNOP_FORTRAN_LOC, false },
1329 /* Implementation of a dynamically expandable buffer for processing input
1330 characters acquired through lexptr and building a value to return in
1331 yylval. Ripped off from ch-exp.y */
1333 static char *tempbuf; /* Current buffer contents */
1334 static int tempbufsize; /* Size of allocated buffer */
1335 static int tempbufindex; /* Current index into buffer */
1337 #define GROWBY_MIN_SIZE 64 /* Minimum amount to grow buffer by */
1339 #define CHECKBUF(size) \
1341 if (tempbufindex + (size) >= tempbufsize) \
1343 growbuf_by_size (size); \
1348 /* Grow the static temp buffer if necessary, including allocating the
1349 first one on demand. */
1352 growbuf_by_size (int count)
1356 growby = std::max (count, GROWBY_MIN_SIZE);
1357 tempbufsize += growby;
1358 if (tempbuf == NULL)
1359 tempbuf = (char *) malloc (tempbufsize);
1361 tempbuf = (char *) realloc (tempbuf, tempbufsize);
1364 /* Blatantly ripped off from ch-exp.y. This routine recognizes F77
1367 Recognize a string literal. A string literal is a nonzero sequence
1368 of characters enclosed in matching single quotes, except that
1369 a single character inside single quotes is a character literal, which
1370 we reject as a string literal. To embed the terminator character inside
1371 a string, it is simply doubled (I.E. 'this''is''one''string') */
1374 match_string_literal (void)
1376 const char *tokptr = pstate->lexptr;
1378 for (tempbufindex = 0, tokptr++; *tokptr != '\0'; tokptr++)
1381 if (*tokptr == *pstate->lexptr)
1383 if (*(tokptr + 1) == *pstate->lexptr)
1388 tempbuf[tempbufindex++] = *tokptr;
1390 if (*tokptr == '\0' /* no terminator */
1391 || tempbufindex == 0) /* no string */
1395 tempbuf[tempbufindex] = '\0';
1396 yylval.sval.ptr = tempbuf;
1397 yylval.sval.length = tempbufindex;
1398 pstate->lexptr = ++tokptr;
1399 return STRING_LITERAL;
1403 /* This is set if a NAME token appeared at the very end of the input
1404 string, with no whitespace separating the name from the EOF. This
1405 is used only when parsing to do field name completion. */
1406 static bool saw_name_at_eof;
1408 /* This is set if the previously-returned token was a structure
1410 static bool last_was_structop;
1412 /* Read one token, getting characters through lexptr. */
1420 const char *tokstart;
1421 bool saw_structop = last_was_structop;
1423 last_was_structop = false;
1427 pstate->prev_lexptr = pstate->lexptr;
1429 tokstart = pstate->lexptr;
1431 /* First of all, let us make sure we are not dealing with the
1432 special tokens .true. and .false. which evaluate to 1 and 0. */
1434 if (*pstate->lexptr == '.')
1436 for (const auto &candidate : boolean_values)
1438 if (strncasecmp (tokstart, candidate.name,
1439 strlen (candidate.name)) == 0)
1441 pstate->lexptr += strlen (candidate.name);
1442 yylval.lval = candidate.value;
1443 return BOOLEAN_LITERAL;
1448 /* See if it is a Fortran operator. */
1449 for (const auto &candidate : fortran_operators)
1450 if (strncasecmp (tokstart, candidate.oper,
1451 strlen (candidate.oper)) == 0)
1453 gdb_assert (!candidate.case_sensitive);
1454 pstate->lexptr += strlen (candidate.oper);
1455 yylval.opcode = candidate.opcode;
1456 return candidate.token;
1459 switch (c = *tokstart)
1462 if (saw_name_at_eof)
1464 saw_name_at_eof = false;
1467 else if (pstate->parse_completion && saw_structop)
1478 token = match_string_literal ();
1489 if (paren_depth == 0)
1496 if (pstate->comma_terminates && paren_depth == 0)
1502 /* Might be a floating point number. */
1503 if (pstate->lexptr[1] < '0' || pstate->lexptr[1] > '9')
1504 goto symbol; /* Nope, must be a symbol. */
1518 /* It's a number. */
1519 int got_dot = 0, got_e = 0, got_d = 0, toktype;
1520 const char *p = tokstart;
1521 int hex = input_radix > 10;
1523 if (c == '0' && (p[1] == 'x' || p[1] == 'X'))
1528 else if (c == '0' && (p[1]=='t' || p[1]=='T'
1529 || p[1]=='d' || p[1]=='D'))
1537 if (!hex && !got_e && (*p == 'e' || *p == 'E'))
1538 got_dot = got_e = 1;
1539 else if (!hex && !got_d && (*p == 'd' || *p == 'D'))
1540 got_dot = got_d = 1;
1541 else if (!hex && !got_dot && *p == '.')
1543 else if (((got_e && (p[-1] == 'e' || p[-1] == 'E'))
1544 || (got_d && (p[-1] == 'd' || p[-1] == 'D')))
1545 && (*p == '-' || *p == '+'))
1546 /* This is the sign of the exponent, not the end of the
1549 /* We will take any letters or digits. parse_number will
1550 complain if past the radix, or if L or U are not final. */
1551 else if ((*p < '0' || *p > '9')
1552 && ((*p < 'a' || *p > 'z')
1553 && (*p < 'A' || *p > 'Z')))
1556 toktype = parse_number (pstate, tokstart, p - tokstart,
1557 got_dot|got_e|got_d,
1559 if (toktype == ERROR)
1561 char *err_copy = (char *) alloca (p - tokstart + 1);
1563 memcpy (err_copy, tokstart, p - tokstart);
1564 err_copy[p - tokstart] = 0;
1565 error (_("Invalid number \"%s\"."), err_copy);
1572 last_was_structop = true;
1598 if (!(c == '_' || c == '$' || c ==':'
1599 || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')))
1600 /* We must have come across a bad character (e.g. ';'). */
1601 error (_("Invalid character '%c' in expression."), c);
1604 for (c = tokstart[namelen];
1605 (c == '_' || c == '$' || c == ':' || (c >= '0' && c <= '9')
1606 || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'));
1607 c = tokstart[++namelen]);
1609 /* The token "if" terminates the expression and is NOT
1610 removed from the input stream. */
1612 if (namelen == 2 && tokstart[0] == 'i' && tokstart[1] == 'f')
1615 pstate->lexptr += namelen;
1617 /* Catch specific keywords. */
1619 for (const auto &keyword : f_keywords)
1620 if (strlen (keyword.oper) == namelen
1621 && ((!keyword.case_sensitive
1622 && strncasecmp (tokstart, keyword.oper, namelen) == 0)
1623 || (keyword.case_sensitive
1624 && strncmp (tokstart, keyword.oper, namelen) == 0)))
1626 yylval.opcode = keyword.opcode;
1627 return keyword.token;
1630 yylval.sval.ptr = tokstart;
1631 yylval.sval.length = namelen;
1633 if (*tokstart == '$')
1634 return DOLLAR_VARIABLE;
1636 /* Use token-type TYPENAME for symbols that happen to be defined
1637 currently as names of types; NAME for other symbols.
1638 The caller is not constrained to care about the distinction. */
1640 std::string tmp = copy_name (yylval.sval);
1641 struct block_symbol result;
1642 const domain_enum lookup_domains[] =
1650 for (const auto &domain : lookup_domains)
1652 result = lookup_symbol (tmp.c_str (), pstate->expression_context_block,
1654 if (result.symbol && result.symbol->aclass () == LOC_TYPEDEF)
1656 yylval.tsym.type = result.symbol->type ();
1665 = language_lookup_primitive_type (pstate->language (),
1666 pstate->gdbarch (), tmp.c_str ());
1667 if (yylval.tsym.type != NULL)
1670 /* Input names that aren't symbols but ARE valid hex numbers,
1671 when the input radix permits them, can be names or numbers
1672 depending on the parse. Note we support radixes > 16 here. */
1674 && ((tokstart[0] >= 'a' && tokstart[0] < 'a' + input_radix - 10)
1675 || (tokstart[0] >= 'A' && tokstart[0] < 'A' + input_radix - 10)))
1677 YYSTYPE newlval; /* Its value is ignored. */
1678 hextype = parse_number (pstate, tokstart, namelen, 0, &newlval);
1681 yylval.ssym.sym = result;
1682 yylval.ssym.is_a_field_of_this = false;
1687 if (pstate->parse_completion && *pstate->lexptr == '\0')
1688 saw_name_at_eof = true;
1690 /* Any other kind of symbol */
1691 yylval.ssym.sym = result;
1692 yylval.ssym.is_a_field_of_this = false;
1698 f_language::parser (struct parser_state *par_state) const
1700 /* Setting up the parser state. */
1701 scoped_restore pstate_restore = make_scoped_restore (&pstate);
1702 scoped_restore restore_yydebug = make_scoped_restore (&yydebug,
1704 gdb_assert (par_state != NULL);
1706 last_was_structop = false;
1707 saw_name_at_eof = false;
1710 struct type_stack stack;
1711 scoped_restore restore_type_stack = make_scoped_restore (&type_stack,
1714 int result = yyparse ();
1716 pstate->set_operation (pstate->pop ());
1721 yyerror (const char *msg)
1723 if (pstate->prev_lexptr)
1724 pstate->lexptr = pstate->prev_lexptr;
1726 error (_("A %s in expression, near `%s'."), msg, pstate->lexptr);