Accept and ignore the R_BPF_64_NODLYD32 relocation.
[binutils-gdb.git] / gdb / f-exp.y
blob18566afd67f59f837cd94a3c521f814a560dfd05
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. */
45 #include "defs.h"
46 #include "expression.h"
47 #include "value.h"
48 #include "parser-defs.h"
49 #include "language.h"
50 #include "f-lang.h"
51 #include "block.h"
52 #include <ctype.h>
53 #include <algorithm>
54 #include "type-stack.h"
55 #include "f-exp.h"
57 #define parse_type(ps) builtin_type (ps->gdbarch ())
58 #define parse_f_type(ps) builtin_f_type (ps->gdbarch ())
60 /* Remap normal yacc parser interface names (yyparse, yylex, yyerror,
61 etc). */
62 #define GDB_YY_REMAP_PREFIX f_
63 #include "yy-remap.h"
65 /* The state of the parser, used internally when we are parsing the
66 expression. */
68 static struct parser_state *pstate = NULL;
70 /* Depth of parentheses. */
71 static int paren_depth;
73 /* The current type stack. */
74 static struct type_stack *type_stack;
76 int yyparse (void);
78 static int yylex (void);
80 static void yyerror (const char *);
82 static void growbuf_by_size (int);
84 static int match_string_literal (void);
86 static void push_kind_type (LONGEST val, struct type *type);
88 static struct type *convert_to_kind_type (struct type *basetype, int kind);
90 static void wrap_unop_intrinsic (exp_opcode opcode);
92 static void wrap_binop_intrinsic (exp_opcode opcode);
94 static void wrap_ternop_intrinsic (exp_opcode opcode);
96 template<typename T>
97 static void fortran_wrap2_kind (type *base_type);
99 template<typename T>
100 static void fortran_wrap3_kind (type *base_type);
102 using namespace expr;
105 /* Although the yacc "value" of an expression is not used,
106 since the result is stored in the structure being created,
107 other node types do have values. */
109 %union
111 LONGEST lval;
112 struct {
113 LONGEST val;
114 struct type *type;
115 } typed_val;
116 struct {
117 gdb_byte val[16];
118 struct type *type;
119 } typed_val_float;
120 struct symbol *sym;
121 struct type *tval;
122 struct stoken sval;
123 struct ttype tsym;
124 struct symtoken ssym;
125 int voidval;
126 enum exp_opcode opcode;
127 struct internalvar *ivar;
129 struct type **tvec;
130 int *ivec;
134 /* YYSTYPE gets defined by %union */
135 static int parse_number (struct parser_state *, const char *, int,
136 int, YYSTYPE *);
139 %type <voidval> exp type_exp start variable
140 %type <tval> type typebase
141 %type <tvec> nonempty_typelist
142 /* %type <bval> block */
144 /* Fancy type parsing. */
145 %type <voidval> func_mod direct_abs_decl abs_decl
146 %type <tval> ptype
148 %token <typed_val> INT
149 %token <typed_val_float> FLOAT
151 /* Both NAME and TYPENAME tokens represent symbols in the input,
152 and both convey their data as strings.
153 But a TYPENAME is a string that happens to be defined as a typedef
154 or builtin type name (such as int or char)
155 and a NAME is any other symbol.
156 Contexts where this distinction is not important can use the
157 nonterminal "name", which matches either NAME or TYPENAME. */
159 %token <sval> STRING_LITERAL
160 %token <lval> BOOLEAN_LITERAL
161 %token <ssym> NAME
162 %token <tsym> TYPENAME
163 %token <voidval> COMPLETE
164 %type <sval> name
165 %type <ssym> name_not_typename
167 /* A NAME_OR_INT is a symbol which is not known in the symbol table,
168 but which would parse as a valid number in the current input radix.
169 E.g. "c" when input_radix==16. Depending on the parse, it will be
170 turned into a name or into a number. */
172 %token <ssym> NAME_OR_INT
174 %token SIZEOF KIND
175 %token ERROR
177 /* Special type cases, put in to allow the parser to distinguish different
178 legal basetypes. */
179 %token INT_S1_KEYWORD INT_S2_KEYWORD INT_KEYWORD INT_S4_KEYWORD INT_S8_KEYWORD
180 %token LOGICAL_S1_KEYWORD LOGICAL_S2_KEYWORD LOGICAL_KEYWORD LOGICAL_S4_KEYWORD
181 %token LOGICAL_S8_KEYWORD
182 %token REAL_KEYWORD REAL_S4_KEYWORD REAL_S8_KEYWORD REAL_S16_KEYWORD
183 %token COMPLEX_KEYWORD COMPLEX_S4_KEYWORD COMPLEX_S8_KEYWORD
184 %token COMPLEX_S16_KEYWORD
185 %token BOOL_AND BOOL_OR BOOL_NOT
186 %token SINGLE DOUBLE PRECISION
187 %token <lval> CHARACTER
189 %token <sval> DOLLAR_VARIABLE
191 %token <opcode> ASSIGN_MODIFY
192 %token <opcode> UNOP_INTRINSIC BINOP_INTRINSIC
193 %token <opcode> UNOP_OR_BINOP_INTRINSIC UNOP_OR_BINOP_OR_TERNOP_INTRINSIC
195 %left ','
196 %left ABOVE_COMMA
197 %right '=' ASSIGN_MODIFY
198 %right '?'
199 %left BOOL_OR
200 %right BOOL_NOT
201 %left BOOL_AND
202 %left '|'
203 %left '^'
204 %left '&'
205 %left EQUAL NOTEQUAL
206 %left LESSTHAN GREATERTHAN LEQ GEQ
207 %left LSH RSH
208 %left '@'
209 %left '+' '-'
210 %left '*' '/'
211 %right STARSTAR
212 %right '%'
213 %right UNARY
214 %right '('
219 start : exp
220 | type_exp
223 type_exp: type
224 { pstate->push_new<type_operation> ($1); }
227 exp : '(' exp ')'
231 /* Expressions, not including the comma operator. */
232 exp : '*' exp %prec UNARY
233 { pstate->wrap<unop_ind_operation> (); }
236 exp : '&' exp %prec UNARY
237 { pstate->wrap<unop_addr_operation> (); }
240 exp : '-' exp %prec UNARY
241 { pstate->wrap<unary_neg_operation> (); }
244 exp : BOOL_NOT exp %prec UNARY
245 { pstate->wrap<unary_logical_not_operation> (); }
248 exp : '~' exp %prec UNARY
249 { pstate->wrap<unary_complement_operation> (); }
252 exp : SIZEOF exp %prec UNARY
253 { pstate->wrap<unop_sizeof_operation> (); }
256 exp : KIND '(' exp ')' %prec UNARY
257 { pstate->wrap<fortran_kind_operation> (); }
260 /* No more explicit array operators, we treat everything in F77 as
261 a function call. The disambiguation as to whether we are
262 doing a subscript operation or a function call is done
263 later in eval.c. */
265 exp : exp '('
266 { pstate->start_arglist (); }
267 arglist ')'
269 std::vector<operation_up> args
270 = pstate->pop_vector (pstate->end_arglist ());
271 pstate->push_new<fortran_undetermined>
272 (pstate->pop (), std::move (args));
276 exp : UNOP_INTRINSIC '(' exp ')'
278 wrap_unop_intrinsic ($1);
282 exp : BINOP_INTRINSIC '(' exp ',' exp ')'
284 wrap_binop_intrinsic ($1);
288 exp : UNOP_OR_BINOP_INTRINSIC '('
289 { pstate->start_arglist (); }
290 arglist ')'
292 const int n = pstate->end_arglist ();
294 switch (n)
296 case 1:
297 wrap_unop_intrinsic ($1);
298 break;
299 case 2:
300 wrap_binop_intrinsic ($1);
301 break;
302 default:
303 gdb_assert_not_reached
304 ("wrong number of arguments for intrinsics");
308 exp : UNOP_OR_BINOP_OR_TERNOP_INTRINSIC '('
309 { pstate->start_arglist (); }
310 arglist ')'
312 const int n = pstate->end_arglist ();
314 switch (n)
316 case 1:
317 wrap_unop_intrinsic ($1);
318 break;
319 case 2:
320 wrap_binop_intrinsic ($1);
321 break;
322 case 3:
323 wrap_ternop_intrinsic ($1);
324 break;
325 default:
326 gdb_assert_not_reached
327 ("wrong number of arguments for intrinsics");
332 arglist :
335 arglist : exp
336 { pstate->arglist_len = 1; }
339 arglist : subrange
340 { pstate->arglist_len = 1; }
343 arglist : arglist ',' exp %prec ABOVE_COMMA
344 { pstate->arglist_len++; }
347 arglist : arglist ',' subrange %prec ABOVE_COMMA
348 { pstate->arglist_len++; }
351 /* There are four sorts of subrange types in F90. */
353 subrange: exp ':' exp %prec ABOVE_COMMA
355 operation_up high = pstate->pop ();
356 operation_up low = pstate->pop ();
357 pstate->push_new<fortran_range_operation>
358 (RANGE_STANDARD, std::move (low),
359 std::move (high), operation_up ());
363 subrange: exp ':' %prec ABOVE_COMMA
365 operation_up low = pstate->pop ();
366 pstate->push_new<fortran_range_operation>
367 (RANGE_HIGH_BOUND_DEFAULT, std::move (low),
368 operation_up (), operation_up ());
372 subrange: ':' exp %prec ABOVE_COMMA
374 operation_up high = pstate->pop ();
375 pstate->push_new<fortran_range_operation>
376 (RANGE_LOW_BOUND_DEFAULT, operation_up (),
377 std::move (high), operation_up ());
381 subrange: ':' %prec ABOVE_COMMA
383 pstate->push_new<fortran_range_operation>
384 (RANGE_LOW_BOUND_DEFAULT
385 | RANGE_HIGH_BOUND_DEFAULT,
386 operation_up (), operation_up (),
387 operation_up ());
391 /* And each of the four subrange types can also have a stride. */
392 subrange: exp ':' exp ':' exp %prec ABOVE_COMMA
394 operation_up stride = pstate->pop ();
395 operation_up high = pstate->pop ();
396 operation_up low = pstate->pop ();
397 pstate->push_new<fortran_range_operation>
398 (RANGE_STANDARD | RANGE_HAS_STRIDE,
399 std::move (low), std::move (high),
400 std::move (stride));
404 subrange: exp ':' ':' exp %prec ABOVE_COMMA
406 operation_up stride = pstate->pop ();
407 operation_up low = pstate->pop ();
408 pstate->push_new<fortran_range_operation>
409 (RANGE_HIGH_BOUND_DEFAULT
410 | RANGE_HAS_STRIDE,
411 std::move (low), operation_up (),
412 std::move (stride));
416 subrange: ':' exp ':' exp %prec ABOVE_COMMA
418 operation_up stride = pstate->pop ();
419 operation_up high = pstate->pop ();
420 pstate->push_new<fortran_range_operation>
421 (RANGE_LOW_BOUND_DEFAULT
422 | RANGE_HAS_STRIDE,
423 operation_up (), std::move (high),
424 std::move (stride));
428 subrange: ':' ':' exp %prec ABOVE_COMMA
430 operation_up stride = pstate->pop ();
431 pstate->push_new<fortran_range_operation>
432 (RANGE_LOW_BOUND_DEFAULT
433 | RANGE_HIGH_BOUND_DEFAULT
434 | RANGE_HAS_STRIDE,
435 operation_up (), operation_up (),
436 std::move (stride));
440 complexnum: exp ',' exp
441 { }
444 exp : '(' complexnum ')'
446 operation_up rhs = pstate->pop ();
447 operation_up lhs = pstate->pop ();
448 pstate->push_new<complex_operation>
449 (std::move (lhs), std::move (rhs),
450 parse_f_type (pstate)->builtin_complex_s16);
454 exp : '(' type ')' exp %prec UNARY
456 pstate->push_new<unop_cast_operation>
457 (pstate->pop (), $2);
461 exp : exp '%' name
463 pstate->push_new<fortran_structop_operation>
464 (pstate->pop (), copy_name ($3));
468 exp : exp '%' name COMPLETE
470 structop_base_operation *op
471 = new fortran_structop_operation (pstate->pop (),
472 copy_name ($3));
473 pstate->mark_struct_expression (op);
474 pstate->push (operation_up (op));
478 exp : exp '%' COMPLETE
480 structop_base_operation *op
481 = new fortran_structop_operation (pstate->pop (),
482 "");
483 pstate->mark_struct_expression (op);
484 pstate->push (operation_up (op));
488 /* Binary operators in order of decreasing precedence. */
490 exp : exp '@' exp
491 { pstate->wrap2<repeat_operation> (); }
494 exp : exp STARSTAR exp
495 { pstate->wrap2<exp_operation> (); }
498 exp : exp '*' exp
499 { pstate->wrap2<mul_operation> (); }
502 exp : exp '/' exp
503 { pstate->wrap2<div_operation> (); }
506 exp : exp '+' exp
507 { pstate->wrap2<add_operation> (); }
510 exp : exp '-' exp
511 { pstate->wrap2<sub_operation> (); }
514 exp : exp LSH exp
515 { pstate->wrap2<lsh_operation> (); }
518 exp : exp RSH exp
519 { pstate->wrap2<rsh_operation> (); }
522 exp : exp EQUAL exp
523 { pstate->wrap2<equal_operation> (); }
526 exp : exp NOTEQUAL exp
527 { pstate->wrap2<notequal_operation> (); }
530 exp : exp LEQ exp
531 { pstate->wrap2<leq_operation> (); }
534 exp : exp GEQ exp
535 { pstate->wrap2<geq_operation> (); }
538 exp : exp LESSTHAN exp
539 { pstate->wrap2<less_operation> (); }
542 exp : exp GREATERTHAN exp
543 { pstate->wrap2<gtr_operation> (); }
546 exp : exp '&' exp
547 { pstate->wrap2<bitwise_and_operation> (); }
550 exp : exp '^' exp
551 { pstate->wrap2<bitwise_xor_operation> (); }
554 exp : exp '|' exp
555 { pstate->wrap2<bitwise_ior_operation> (); }
558 exp : exp BOOL_AND exp
559 { pstate->wrap2<logical_and_operation> (); }
563 exp : exp BOOL_OR exp
564 { pstate->wrap2<logical_or_operation> (); }
567 exp : exp '=' exp
568 { pstate->wrap2<assign_operation> (); }
571 exp : exp ASSIGN_MODIFY exp
573 operation_up rhs = pstate->pop ();
574 operation_up lhs = pstate->pop ();
575 pstate->push_new<assign_modify_operation>
576 ($2, std::move (lhs), std::move (rhs));
580 exp : INT
582 pstate->push_new<long_const_operation>
583 ($1.type, $1.val);
587 exp : NAME_OR_INT
588 { YYSTYPE val;
589 parse_number (pstate, $1.stoken.ptr,
590 $1.stoken.length, 0, &val);
591 pstate->push_new<long_const_operation>
592 (val.typed_val.type,
593 val.typed_val.val);
597 exp : FLOAT
599 float_data data;
600 std::copy (std::begin ($1.val), std::end ($1.val),
601 std::begin (data));
602 pstate->push_new<float_const_operation> ($1.type, data);
606 exp : variable
609 exp : DOLLAR_VARIABLE
610 { pstate->push_dollar ($1); }
613 exp : SIZEOF '(' type ')' %prec UNARY
615 $3 = check_typedef ($3);
616 pstate->push_new<long_const_operation>
617 (parse_f_type (pstate)->builtin_integer,
618 $3->length ());
622 exp : BOOLEAN_LITERAL
623 { pstate->push_new<bool_operation> ($1); }
626 exp : STRING_LITERAL
628 pstate->push_new<string_operation>
629 (copy_name ($1));
633 variable: name_not_typename
634 { struct block_symbol sym = $1.sym;
635 std::string name = copy_name ($1.stoken);
636 pstate->push_symbol (name.c_str (), sym);
641 type : ptype
644 ptype : typebase
645 | typebase abs_decl
647 /* This is where the interesting stuff happens. */
648 int done = 0;
649 int array_size;
650 struct type *follow_type = $1;
651 struct type *range_type;
653 while (!done)
654 switch (type_stack->pop ())
656 case tp_end:
657 done = 1;
658 break;
659 case tp_pointer:
660 follow_type = lookup_pointer_type (follow_type);
661 break;
662 case tp_reference:
663 follow_type = lookup_lvalue_reference_type (follow_type);
664 break;
665 case tp_array:
666 array_size = type_stack->pop_int ();
667 if (array_size != -1)
669 struct type *idx_type
670 = parse_f_type (pstate)->builtin_integer;
671 type_allocator alloc (idx_type);
672 range_type =
673 create_static_range_type (alloc, idx_type,
674 0, array_size - 1);
675 follow_type = create_array_type (alloc,
676 follow_type,
677 range_type);
679 else
680 follow_type = lookup_pointer_type (follow_type);
681 break;
682 case tp_function:
683 follow_type = lookup_function_type (follow_type);
684 break;
685 case tp_kind:
687 int kind_val = type_stack->pop_int ();
688 follow_type
689 = convert_to_kind_type (follow_type, kind_val);
691 break;
693 $$ = follow_type;
697 abs_decl: '*'
698 { type_stack->push (tp_pointer); $$ = 0; }
699 | '*' abs_decl
700 { type_stack->push (tp_pointer); $$ = $2; }
701 | '&'
702 { type_stack->push (tp_reference); $$ = 0; }
703 | '&' abs_decl
704 { type_stack->push (tp_reference); $$ = $2; }
705 | direct_abs_decl
708 direct_abs_decl: '(' abs_decl ')'
709 { $$ = $2; }
710 | '(' KIND '=' INT ')'
711 { push_kind_type ($4.val, $4.type); }
712 | '*' INT
713 { push_kind_type ($2.val, $2.type); }
714 | direct_abs_decl func_mod
715 { type_stack->push (tp_function); }
716 | func_mod
717 { type_stack->push (tp_function); }
720 func_mod: '(' ')'
721 { $$ = 0; }
722 | '(' nonempty_typelist ')'
723 { free ($2); $$ = 0; }
726 typebase /* Implements (approximately): (type-qualifier)* type-specifier */
727 : TYPENAME
728 { $$ = $1.type; }
729 | INT_S1_KEYWORD
730 { $$ = parse_f_type (pstate)->builtin_integer_s1; }
731 | INT_S2_KEYWORD
732 { $$ = parse_f_type (pstate)->builtin_integer_s2; }
733 | INT_KEYWORD
734 { $$ = parse_f_type (pstate)->builtin_integer; }
735 | INT_S4_KEYWORD
736 { $$ = parse_f_type (pstate)->builtin_integer; }
737 | INT_S8_KEYWORD
738 { $$ = parse_f_type (pstate)->builtin_integer_s8; }
739 | CHARACTER
740 { $$ = parse_f_type (pstate)->builtin_character; }
741 | LOGICAL_S1_KEYWORD
742 { $$ = parse_f_type (pstate)->builtin_logical_s1; }
743 | LOGICAL_S2_KEYWORD
744 { $$ = parse_f_type (pstate)->builtin_logical_s2; }
745 | LOGICAL_KEYWORD
746 { $$ = parse_f_type (pstate)->builtin_logical; }
747 | LOGICAL_S4_KEYWORD
748 { $$ = parse_f_type (pstate)->builtin_logical; }
749 | LOGICAL_S8_KEYWORD
750 { $$ = parse_f_type (pstate)->builtin_logical_s8; }
751 | REAL_KEYWORD
752 { $$ = parse_f_type (pstate)->builtin_real; }
753 | REAL_S4_KEYWORD
754 { $$ = parse_f_type (pstate)->builtin_real; }
755 | REAL_S8_KEYWORD
756 { $$ = parse_f_type (pstate)->builtin_real_s8; }
757 | REAL_S16_KEYWORD
758 { $$ = parse_f_type (pstate)->builtin_real_s16; }
759 | COMPLEX_KEYWORD
760 { $$ = parse_f_type (pstate)->builtin_complex; }
761 | COMPLEX_S4_KEYWORD
762 { $$ = parse_f_type (pstate)->builtin_complex; }
763 | COMPLEX_S8_KEYWORD
764 { $$ = parse_f_type (pstate)->builtin_complex_s8; }
765 | COMPLEX_S16_KEYWORD
766 { $$ = parse_f_type (pstate)->builtin_complex_s16; }
767 | SINGLE PRECISION
768 { $$ = parse_f_type (pstate)->builtin_real;}
769 | DOUBLE PRECISION
770 { $$ = parse_f_type (pstate)->builtin_real_s8;}
771 | SINGLE COMPLEX_KEYWORD
772 { $$ = parse_f_type (pstate)->builtin_complex;}
773 | DOUBLE COMPLEX_KEYWORD
774 { $$ = parse_f_type (pstate)->builtin_complex_s8;}
777 nonempty_typelist
778 : type
779 { $$ = (struct type **) malloc (sizeof (struct type *) * 2);
780 $<ivec>$[0] = 1; /* Number of types in vector */
781 $$[1] = $1;
783 | nonempty_typelist ',' type
784 { int len = sizeof (struct type *) * (++($<ivec>1[0]) + 1);
785 $$ = (struct type **) realloc ((char *) $1, len);
786 $$[$<ivec>$[0]] = $3;
790 name
791 : NAME
792 { $$ = $1.stoken; }
793 | TYPENAME
794 { $$ = $1.stoken; }
797 name_not_typename : NAME
798 /* These would be useful if name_not_typename was useful, but it is just
799 a fake for "variable", so these cause reduce/reduce conflicts because
800 the parser can't tell whether NAME_OR_INT is a name_not_typename (=variable,
801 =exp) or just an exp. If name_not_typename was ever used in an lvalue
802 context where only a name could occur, this might be useful.
803 | NAME_OR_INT
809 /* Called to match intrinsic function calls with one argument to their
810 respective implementation and push the operation. */
812 static void
813 wrap_unop_intrinsic (exp_opcode code)
815 switch (code)
817 case UNOP_ABS:
818 pstate->wrap<fortran_abs_operation> ();
819 break;
820 case FORTRAN_FLOOR:
821 pstate->wrap<fortran_floor_operation_1arg> ();
822 break;
823 case FORTRAN_CEILING:
824 pstate->wrap<fortran_ceil_operation_1arg> ();
825 break;
826 case UNOP_FORTRAN_ALLOCATED:
827 pstate->wrap<fortran_allocated_operation> ();
828 break;
829 case UNOP_FORTRAN_RANK:
830 pstate->wrap<fortran_rank_operation> ();
831 break;
832 case UNOP_FORTRAN_SHAPE:
833 pstate->wrap<fortran_array_shape_operation> ();
834 break;
835 case UNOP_FORTRAN_LOC:
836 pstate->wrap<fortran_loc_operation> ();
837 break;
838 case FORTRAN_ASSOCIATED:
839 pstate->wrap<fortran_associated_1arg> ();
840 break;
841 case FORTRAN_ARRAY_SIZE:
842 pstate->wrap<fortran_array_size_1arg> ();
843 break;
844 case FORTRAN_CMPLX:
845 pstate->wrap<fortran_cmplx_operation_1arg> ();
846 break;
847 case FORTRAN_LBOUND:
848 case FORTRAN_UBOUND:
849 pstate->push_new<fortran_bound_1arg> (code, pstate->pop ());
850 break;
851 default:
852 gdb_assert_not_reached ("unhandled intrinsic");
856 /* Called to match intrinsic function calls with two arguments to their
857 respective implementation and push the operation. */
859 static void
860 wrap_binop_intrinsic (exp_opcode code)
862 switch (code)
864 case FORTRAN_FLOOR:
865 fortran_wrap2_kind<fortran_floor_operation_2arg>
866 (parse_f_type (pstate)->builtin_integer);
867 break;
868 case FORTRAN_CEILING:
869 fortran_wrap2_kind<fortran_ceil_operation_2arg>
870 (parse_f_type (pstate)->builtin_integer);
871 break;
872 case BINOP_MOD:
873 pstate->wrap2<fortran_mod_operation> ();
874 break;
875 case BINOP_FORTRAN_MODULO:
876 pstate->wrap2<fortran_modulo_operation> ();
877 break;
878 case FORTRAN_CMPLX:
879 pstate->wrap2<fortran_cmplx_operation_2arg> ();
880 break;
881 case FORTRAN_ASSOCIATED:
882 pstate->wrap2<fortran_associated_2arg> ();
883 break;
884 case FORTRAN_ARRAY_SIZE:
885 pstate->wrap2<fortran_array_size_2arg> ();
886 break;
887 case FORTRAN_LBOUND:
888 case FORTRAN_UBOUND:
890 operation_up arg2 = pstate->pop ();
891 operation_up arg1 = pstate->pop ();
892 pstate->push_new<fortran_bound_2arg> (code, std::move (arg1),
893 std::move (arg2));
895 break;
896 default:
897 gdb_assert_not_reached ("unhandled intrinsic");
901 /* Called to match intrinsic function calls with three arguments to their
902 respective implementation and push the operation. */
904 static void
905 wrap_ternop_intrinsic (exp_opcode code)
907 switch (code)
909 case FORTRAN_LBOUND:
910 case FORTRAN_UBOUND:
912 operation_up kind_arg = pstate->pop ();
913 operation_up arg2 = pstate->pop ();
914 operation_up arg1 = pstate->pop ();
916 value *val = kind_arg->evaluate (nullptr, pstate->expout.get (),
917 EVAL_AVOID_SIDE_EFFECTS);
918 gdb_assert (val != nullptr);
920 type *follow_type
921 = convert_to_kind_type (parse_f_type (pstate)->builtin_integer,
922 value_as_long (val));
924 pstate->push_new<fortran_bound_3arg> (code, std::move (arg1),
925 std::move (arg2), follow_type);
927 break;
928 case FORTRAN_ARRAY_SIZE:
929 fortran_wrap3_kind<fortran_array_size_3arg>
930 (parse_f_type (pstate)->builtin_integer);
931 break;
932 case FORTRAN_CMPLX:
933 fortran_wrap3_kind<fortran_cmplx_operation_3arg>
934 (parse_f_type (pstate)->builtin_complex);
935 break;
936 default:
937 gdb_assert_not_reached ("unhandled intrinsic");
941 /* A helper that pops two operations (similar to wrap2), evaluates the last one
942 assuming it is a kind parameter, and wraps them in some other operation
943 pushing it to the stack. */
945 template<typename T>
946 static void
947 fortran_wrap2_kind (type *base_type)
949 operation_up kind_arg = pstate->pop ();
950 operation_up arg = pstate->pop ();
952 value *val = kind_arg->evaluate (nullptr, pstate->expout.get (),
953 EVAL_AVOID_SIDE_EFFECTS);
954 gdb_assert (val != nullptr);
956 type *follow_type = convert_to_kind_type (base_type, value_as_long (val));
958 pstate->push_new<T> (std::move (arg), follow_type);
961 /* A helper that pops three operations, evaluates the last one assuming it is a
962 kind parameter, and wraps them in some other operation pushing it to the
963 stack. */
965 template<typename T>
966 static void
967 fortran_wrap3_kind (type *base_type)
969 operation_up kind_arg = pstate->pop ();
970 operation_up arg2 = pstate->pop ();
971 operation_up arg1 = pstate->pop ();
973 value *val = kind_arg->evaluate (nullptr, pstate->expout.get (),
974 EVAL_AVOID_SIDE_EFFECTS);
975 gdb_assert (val != nullptr);
977 type *follow_type = convert_to_kind_type (base_type, value_as_long (val));
979 pstate->push_new<T> (std::move (arg1), std::move (arg2), follow_type);
982 /* Take care of parsing a number (anything that starts with a digit).
983 Set yylval and return the token type; update lexptr.
984 LEN is the number of characters in it. */
986 /*** Needs some error checking for the float case ***/
988 static int
989 parse_number (struct parser_state *par_state,
990 const char *p, int len, int parsed_float, YYSTYPE *putithere)
992 ULONGEST n = 0;
993 ULONGEST prevn = 0;
994 int c;
995 int base = input_radix;
996 int unsigned_p = 0;
997 int long_p = 0;
998 ULONGEST high_bit;
999 struct type *signed_type;
1000 struct type *unsigned_type;
1002 if (parsed_float)
1004 /* It's a float since it contains a point or an exponent. */
1005 /* [dD] is not understood as an exponent by parse_float,
1006 change it to 'e'. */
1007 char *tmp, *tmp2;
1009 tmp = xstrdup (p);
1010 for (tmp2 = tmp; *tmp2; ++tmp2)
1011 if (*tmp2 == 'd' || *tmp2 == 'D')
1012 *tmp2 = 'e';
1014 /* FIXME: Should this use different types? */
1015 putithere->typed_val_float.type = parse_f_type (pstate)->builtin_real_s8;
1016 bool parsed = parse_float (tmp, len,
1017 putithere->typed_val_float.type,
1018 putithere->typed_val_float.val);
1019 free (tmp);
1020 return parsed? FLOAT : ERROR;
1023 /* Handle base-switching prefixes 0x, 0t, 0d, 0 */
1024 if (p[0] == '0' && len > 1)
1025 switch (p[1])
1027 case 'x':
1028 case 'X':
1029 if (len >= 3)
1031 p += 2;
1032 base = 16;
1033 len -= 2;
1035 break;
1037 case 't':
1038 case 'T':
1039 case 'd':
1040 case 'D':
1041 if (len >= 3)
1043 p += 2;
1044 base = 10;
1045 len -= 2;
1047 break;
1049 default:
1050 base = 8;
1051 break;
1054 while (len-- > 0)
1056 c = *p++;
1057 if (isupper (c))
1058 c = tolower (c);
1059 if (len == 0 && c == 'l')
1060 long_p = 1;
1061 else if (len == 0 && c == 'u')
1062 unsigned_p = 1;
1063 else
1065 int i;
1066 if (c >= '0' && c <= '9')
1067 i = c - '0';
1068 else if (c >= 'a' && c <= 'f')
1069 i = c - 'a' + 10;
1070 else
1071 return ERROR; /* Char not a digit */
1072 if (i >= base)
1073 return ERROR; /* Invalid digit in this base */
1074 n *= base;
1075 n += i;
1077 /* Test for overflow. */
1078 if (prevn == 0 && n == 0)
1080 else if (RANGE_CHECK && prevn >= n)
1081 range_error (_("Overflow on numeric constant."));
1082 prevn = n;
1085 /* If the number is too big to be an int, or it's got an l suffix
1086 then it's a long. Work out if this has to be a long by
1087 shifting right and seeing if anything remains, and the
1088 target int size is different to the target long size.
1090 In the expression below, we could have tested
1091 (n >> gdbarch_int_bit (parse_gdbarch))
1092 to see if it was zero,
1093 but too many compilers warn about that, when ints and longs
1094 are the same size. So we shift it twice, with fewer bits
1095 each time, for the same result. */
1097 int bits_available;
1098 if ((gdbarch_int_bit (par_state->gdbarch ())
1099 != gdbarch_long_bit (par_state->gdbarch ())
1100 && ((n >> 2)
1101 >> (gdbarch_int_bit (par_state->gdbarch ())-2))) /* Avoid
1102 shift warning */
1103 || long_p)
1105 bits_available = gdbarch_long_bit (par_state->gdbarch ());
1106 unsigned_type = parse_type (par_state)->builtin_unsigned_long;
1107 signed_type = parse_type (par_state)->builtin_long;
1109 else
1111 bits_available = gdbarch_int_bit (par_state->gdbarch ());
1112 unsigned_type = parse_type (par_state)->builtin_unsigned_int;
1113 signed_type = parse_type (par_state)->builtin_int;
1115 high_bit = ((ULONGEST)1) << (bits_available - 1);
1117 if (RANGE_CHECK
1118 && ((n >> 2) >> (bits_available - 2)))
1119 range_error (_("Overflow on numeric constant."));
1121 putithere->typed_val.val = n;
1123 /* If the high bit of the worked out type is set then this number
1124 has to be unsigned. */
1126 if (unsigned_p || (n & high_bit))
1127 putithere->typed_val.type = unsigned_type;
1128 else
1129 putithere->typed_val.type = signed_type;
1131 return INT;
1134 /* Called to setup the type stack when we encounter a '(kind=N)' type
1135 modifier, performs some bounds checking on 'N' and then pushes this to
1136 the type stack followed by the 'tp_kind' marker. */
1137 static void
1138 push_kind_type (LONGEST val, struct type *type)
1140 int ival;
1142 if (type->is_unsigned ())
1144 ULONGEST uval = static_cast <ULONGEST> (val);
1145 if (uval > INT_MAX)
1146 error (_("kind value out of range"));
1147 ival = static_cast <int> (uval);
1149 else
1151 if (val > INT_MAX || val < 0)
1152 error (_("kind value out of range"));
1153 ival = static_cast <int> (val);
1156 type_stack->push (ival);
1157 type_stack->push (tp_kind);
1160 /* Called when a type has a '(kind=N)' modifier after it, for example
1161 'character(kind=1)'. The BASETYPE is the type described by 'character'
1162 in our example, and KIND is the integer '1'. This function returns a
1163 new type that represents the basetype of a specific kind. */
1164 static struct type *
1165 convert_to_kind_type (struct type *basetype, int kind)
1167 if (basetype == parse_f_type (pstate)->builtin_character)
1169 /* Character of kind 1 is a special case, this is the same as the
1170 base character type. */
1171 if (kind == 1)
1172 return parse_f_type (pstate)->builtin_character;
1174 else if (basetype == parse_f_type (pstate)->builtin_complex)
1176 if (kind == 4)
1177 return parse_f_type (pstate)->builtin_complex;
1178 else if (kind == 8)
1179 return parse_f_type (pstate)->builtin_complex_s8;
1180 else if (kind == 16)
1181 return parse_f_type (pstate)->builtin_complex_s16;
1183 else if (basetype == parse_f_type (pstate)->builtin_real)
1185 if (kind == 4)
1186 return parse_f_type (pstate)->builtin_real;
1187 else if (kind == 8)
1188 return parse_f_type (pstate)->builtin_real_s8;
1189 else if (kind == 16)
1190 return parse_f_type (pstate)->builtin_real_s16;
1192 else if (basetype == parse_f_type (pstate)->builtin_logical)
1194 if (kind == 1)
1195 return parse_f_type (pstate)->builtin_logical_s1;
1196 else if (kind == 2)
1197 return parse_f_type (pstate)->builtin_logical_s2;
1198 else if (kind == 4)
1199 return parse_f_type (pstate)->builtin_logical;
1200 else if (kind == 8)
1201 return parse_f_type (pstate)->builtin_logical_s8;
1203 else if (basetype == parse_f_type (pstate)->builtin_integer)
1205 if (kind == 1)
1206 return parse_f_type (pstate)->builtin_integer_s1;
1207 else if (kind == 2)
1208 return parse_f_type (pstate)->builtin_integer_s2;
1209 else if (kind == 4)
1210 return parse_f_type (pstate)->builtin_integer;
1211 else if (kind == 8)
1212 return parse_f_type (pstate)->builtin_integer_s8;
1215 error (_("unsupported kind %d for type %s"),
1216 kind, TYPE_SAFE_NAME (basetype));
1218 /* Should never get here. */
1219 return nullptr;
1222 struct f_token
1224 /* The string to match against. */
1225 const char *oper;
1227 /* The lexer token to return. */
1228 int token;
1230 /* The expression opcode to embed within the token. */
1231 enum exp_opcode opcode;
1233 /* When this is true the string in OPER is matched exactly including
1234 case, when this is false OPER is matched case insensitively. */
1235 bool case_sensitive;
1238 /* List of Fortran operators. */
1240 static const struct f_token fortran_operators[] =
1242 { ".and.", BOOL_AND, OP_NULL, false },
1243 { ".or.", BOOL_OR, OP_NULL, false },
1244 { ".not.", BOOL_NOT, OP_NULL, false },
1245 { ".eq.", EQUAL, OP_NULL, false },
1246 { ".eqv.", EQUAL, OP_NULL, false },
1247 { ".neqv.", NOTEQUAL, OP_NULL, false },
1248 { ".xor.", NOTEQUAL, OP_NULL, false },
1249 { "==", EQUAL, OP_NULL, false },
1250 { ".ne.", NOTEQUAL, OP_NULL, false },
1251 { "/=", NOTEQUAL, OP_NULL, false },
1252 { ".le.", LEQ, OP_NULL, false },
1253 { "<=", LEQ, OP_NULL, false },
1254 { ".ge.", GEQ, OP_NULL, false },
1255 { ">=", GEQ, OP_NULL, false },
1256 { ".gt.", GREATERTHAN, OP_NULL, false },
1257 { ">", GREATERTHAN, OP_NULL, false },
1258 { ".lt.", LESSTHAN, OP_NULL, false },
1259 { "<", LESSTHAN, OP_NULL, false },
1260 { "**", STARSTAR, BINOP_EXP, false },
1263 /* Holds the Fortran representation of a boolean, and the integer value we
1264 substitute in when one of the matching strings is parsed. */
1265 struct f77_boolean_val
1267 /* The string representing a Fortran boolean. */
1268 const char *name;
1270 /* The integer value to replace it with. */
1271 int value;
1274 /* The set of Fortran booleans. These are matched case insensitively. */
1275 static const struct f77_boolean_val boolean_values[] =
1277 { ".true.", 1 },
1278 { ".false.", 0 }
1281 static const struct f_token f_intrinsics[] =
1283 /* The following correspond to actual functions in Fortran and are case
1284 insensitive. */
1285 { "kind", KIND, OP_NULL, false },
1286 { "abs", UNOP_INTRINSIC, UNOP_ABS, false },
1287 { "mod", BINOP_INTRINSIC, BINOP_MOD, false },
1288 { "floor", UNOP_OR_BINOP_INTRINSIC, FORTRAN_FLOOR, false },
1289 { "ceiling", UNOP_OR_BINOP_INTRINSIC, FORTRAN_CEILING, false },
1290 { "modulo", BINOP_INTRINSIC, BINOP_FORTRAN_MODULO, false },
1291 { "cmplx", UNOP_OR_BINOP_OR_TERNOP_INTRINSIC, FORTRAN_CMPLX, false },
1292 { "lbound", UNOP_OR_BINOP_OR_TERNOP_INTRINSIC, FORTRAN_LBOUND, false },
1293 { "ubound", UNOP_OR_BINOP_OR_TERNOP_INTRINSIC, FORTRAN_UBOUND, false },
1294 { "allocated", UNOP_INTRINSIC, UNOP_FORTRAN_ALLOCATED, false },
1295 { "associated", UNOP_OR_BINOP_INTRINSIC, FORTRAN_ASSOCIATED, false },
1296 { "rank", UNOP_INTRINSIC, UNOP_FORTRAN_RANK, false },
1297 { "size", UNOP_OR_BINOP_OR_TERNOP_INTRINSIC, FORTRAN_ARRAY_SIZE, false },
1298 { "shape", UNOP_INTRINSIC, UNOP_FORTRAN_SHAPE, false },
1299 { "loc", UNOP_INTRINSIC, UNOP_FORTRAN_LOC, false },
1300 { "sizeof", SIZEOF, OP_NULL, false },
1303 static const f_token f_keywords[] =
1305 /* Historically these have always been lowercase only in GDB. */
1306 { "character", CHARACTER, OP_NULL, true },
1307 { "complex", COMPLEX_KEYWORD, OP_NULL, true },
1308 { "complex_4", COMPLEX_S4_KEYWORD, OP_NULL, true },
1309 { "complex_8", COMPLEX_S8_KEYWORD, OP_NULL, true },
1310 { "complex_16", COMPLEX_S16_KEYWORD, OP_NULL, true },
1311 { "integer_1", INT_S1_KEYWORD, OP_NULL, true },
1312 { "integer_2", INT_S2_KEYWORD, OP_NULL, true },
1313 { "integer_4", INT_S4_KEYWORD, OP_NULL, true },
1314 { "integer", INT_KEYWORD, OP_NULL, true },
1315 { "integer_8", INT_S8_KEYWORD, OP_NULL, true },
1316 { "logical_1", LOGICAL_S1_KEYWORD, OP_NULL, true },
1317 { "logical_2", LOGICAL_S2_KEYWORD, OP_NULL, true },
1318 { "logical", LOGICAL_KEYWORD, OP_NULL, true },
1319 { "logical_4", LOGICAL_S4_KEYWORD, OP_NULL, true },
1320 { "logical_8", LOGICAL_S8_KEYWORD, OP_NULL, true },
1321 { "real", REAL_KEYWORD, OP_NULL, true },
1322 { "real_4", REAL_S4_KEYWORD, OP_NULL, true },
1323 { "real_8", REAL_S8_KEYWORD, OP_NULL, true },
1324 { "real_16", REAL_S16_KEYWORD, OP_NULL, true },
1325 { "single", SINGLE, OP_NULL, true },
1326 { "double", DOUBLE, OP_NULL, true },
1327 { "precision", PRECISION, OP_NULL, true },
1330 /* Implementation of a dynamically expandable buffer for processing input
1331 characters acquired through lexptr and building a value to return in
1332 yylval. Ripped off from ch-exp.y */
1334 static char *tempbuf; /* Current buffer contents */
1335 static int tempbufsize; /* Size of allocated buffer */
1336 static int tempbufindex; /* Current index into buffer */
1338 #define GROWBY_MIN_SIZE 64 /* Minimum amount to grow buffer by */
1340 #define CHECKBUF(size) \
1341 do { \
1342 if (tempbufindex + (size) >= tempbufsize) \
1344 growbuf_by_size (size); \
1346 } while (0);
1349 /* Grow the static temp buffer if necessary, including allocating the
1350 first one on demand. */
1352 static void
1353 growbuf_by_size (int count)
1355 int growby;
1357 growby = std::max (count, GROWBY_MIN_SIZE);
1358 tempbufsize += growby;
1359 if (tempbuf == NULL)
1360 tempbuf = (char *) malloc (tempbufsize);
1361 else
1362 tempbuf = (char *) realloc (tempbuf, tempbufsize);
1365 /* Blatantly ripped off from ch-exp.y. This routine recognizes F77
1366 string-literals.
1368 Recognize a string literal. A string literal is a nonzero sequence
1369 of characters enclosed in matching single quotes, except that
1370 a single character inside single quotes is a character literal, which
1371 we reject as a string literal. To embed the terminator character inside
1372 a string, it is simply doubled (I.E. 'this''is''one''string') */
1374 static int
1375 match_string_literal (void)
1377 const char *tokptr = pstate->lexptr;
1379 for (tempbufindex = 0, tokptr++; *tokptr != '\0'; tokptr++)
1381 CHECKBUF (1);
1382 if (*tokptr == *pstate->lexptr)
1384 if (*(tokptr + 1) == *pstate->lexptr)
1385 tokptr++;
1386 else
1387 break;
1389 tempbuf[tempbufindex++] = *tokptr;
1391 if (*tokptr == '\0' /* no terminator */
1392 || tempbufindex == 0) /* no string */
1393 return 0;
1394 else
1396 tempbuf[tempbufindex] = '\0';
1397 yylval.sval.ptr = tempbuf;
1398 yylval.sval.length = tempbufindex;
1399 pstate->lexptr = ++tokptr;
1400 return STRING_LITERAL;
1404 /* This is set if a NAME token appeared at the very end of the input
1405 string, with no whitespace separating the name from the EOF. This
1406 is used only when parsing to do field name completion. */
1407 static bool saw_name_at_eof;
1409 /* This is set if the previously-returned token was a structure
1410 operator '%'. */
1411 static bool last_was_structop;
1413 /* Read one token, getting characters through lexptr. */
1415 static int
1416 yylex (void)
1418 int c;
1419 int namelen;
1420 unsigned int token;
1421 const char *tokstart;
1422 bool saw_structop = last_was_structop;
1424 last_was_structop = false;
1426 retry:
1428 pstate->prev_lexptr = pstate->lexptr;
1430 tokstart = pstate->lexptr;
1432 /* First of all, let us make sure we are not dealing with the
1433 special tokens .true. and .false. which evaluate to 1 and 0. */
1435 if (*pstate->lexptr == '.')
1437 for (const auto &candidate : boolean_values)
1439 if (strncasecmp (tokstart, candidate.name,
1440 strlen (candidate.name)) == 0)
1442 pstate->lexptr += strlen (candidate.name);
1443 yylval.lval = candidate.value;
1444 return BOOLEAN_LITERAL;
1449 /* See if it is a Fortran operator. */
1450 for (const auto &candidate : fortran_operators)
1451 if (strncasecmp (tokstart, candidate.oper,
1452 strlen (candidate.oper)) == 0)
1454 gdb_assert (!candidate.case_sensitive);
1455 pstate->lexptr += strlen (candidate.oper);
1456 yylval.opcode = candidate.opcode;
1457 return candidate.token;
1460 switch (c = *tokstart)
1462 case 0:
1463 if (saw_name_at_eof)
1465 saw_name_at_eof = false;
1466 return COMPLETE;
1468 else if (pstate->parse_completion && saw_structop)
1469 return COMPLETE;
1470 return 0;
1472 case ' ':
1473 case '\t':
1474 case '\n':
1475 pstate->lexptr++;
1476 goto retry;
1478 case '\'':
1479 token = match_string_literal ();
1480 if (token != 0)
1481 return (token);
1482 break;
1484 case '(':
1485 paren_depth++;
1486 pstate->lexptr++;
1487 return c;
1489 case ')':
1490 if (paren_depth == 0)
1491 return 0;
1492 paren_depth--;
1493 pstate->lexptr++;
1494 return c;
1496 case ',':
1497 if (pstate->comma_terminates && paren_depth == 0)
1498 return 0;
1499 pstate->lexptr++;
1500 return c;
1502 case '.':
1503 /* Might be a floating point number. */
1504 if (pstate->lexptr[1] < '0' || pstate->lexptr[1] > '9')
1505 goto symbol; /* Nope, must be a symbol. */
1506 /* FALL THRU. */
1508 case '0':
1509 case '1':
1510 case '2':
1511 case '3':
1512 case '4':
1513 case '5':
1514 case '6':
1515 case '7':
1516 case '8':
1517 case '9':
1519 /* It's a number. */
1520 int got_dot = 0, got_e = 0, got_d = 0, toktype;
1521 const char *p = tokstart;
1522 int hex = input_radix > 10;
1524 if (c == '0' && (p[1] == 'x' || p[1] == 'X'))
1526 p += 2;
1527 hex = 1;
1529 else if (c == '0' && (p[1]=='t' || p[1]=='T'
1530 || p[1]=='d' || p[1]=='D'))
1532 p += 2;
1533 hex = 0;
1536 for (;; ++p)
1538 if (!hex && !got_e && (*p == 'e' || *p == 'E'))
1539 got_dot = got_e = 1;
1540 else if (!hex && !got_d && (*p == 'd' || *p == 'D'))
1541 got_dot = got_d = 1;
1542 else if (!hex && !got_dot && *p == '.')
1543 got_dot = 1;
1544 else if (((got_e && (p[-1] == 'e' || p[-1] == 'E'))
1545 || (got_d && (p[-1] == 'd' || p[-1] == 'D')))
1546 && (*p == '-' || *p == '+'))
1547 /* This is the sign of the exponent, not the end of the
1548 number. */
1549 continue;
1550 /* We will take any letters or digits. parse_number will
1551 complain if past the radix, or if L or U are not final. */
1552 else if ((*p < '0' || *p > '9')
1553 && ((*p < 'a' || *p > 'z')
1554 && (*p < 'A' || *p > 'Z')))
1555 break;
1557 toktype = parse_number (pstate, tokstart, p - tokstart,
1558 got_dot|got_e|got_d,
1559 &yylval);
1560 if (toktype == ERROR)
1562 char *err_copy = (char *) alloca (p - tokstart + 1);
1564 memcpy (err_copy, tokstart, p - tokstart);
1565 err_copy[p - tokstart] = 0;
1566 error (_("Invalid number \"%s\"."), err_copy);
1568 pstate->lexptr = p;
1569 return toktype;
1572 case '%':
1573 last_was_structop = true;
1574 /* Fall through. */
1575 case '+':
1576 case '-':
1577 case '*':
1578 case '/':
1579 case '|':
1580 case '&':
1581 case '^':
1582 case '~':
1583 case '!':
1584 case '@':
1585 case '<':
1586 case '>':
1587 case '[':
1588 case ']':
1589 case '?':
1590 case ':':
1591 case '=':
1592 case '{':
1593 case '}':
1594 symbol:
1595 pstate->lexptr++;
1596 return c;
1599 if (!(c == '_' || c == '$' || c ==':'
1600 || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')))
1601 /* We must have come across a bad character (e.g. ';'). */
1602 error (_("Invalid character '%c' in expression."), c);
1604 namelen = 0;
1605 for (c = tokstart[namelen];
1606 (c == '_' || c == '$' || c == ':' || (c >= '0' && c <= '9')
1607 || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'));
1608 c = tokstart[++namelen]);
1610 /* The token "if" terminates the expression and is NOT
1611 removed from the input stream. */
1613 if (namelen == 2 && tokstart[0] == 'i' && tokstart[1] == 'f')
1614 return 0;
1616 pstate->lexptr += namelen;
1618 /* Catch specific keywords. */
1620 for (const auto &keyword : f_keywords)
1621 if (strlen (keyword.oper) == namelen
1622 && ((!keyword.case_sensitive
1623 && strncasecmp (tokstart, keyword.oper, namelen) == 0)
1624 || (keyword.case_sensitive
1625 && strncmp (tokstart, keyword.oper, namelen) == 0)))
1627 yylval.opcode = keyword.opcode;
1628 return keyword.token;
1631 yylval.sval.ptr = tokstart;
1632 yylval.sval.length = namelen;
1634 if (*tokstart == '$')
1635 return DOLLAR_VARIABLE;
1637 /* Use token-type TYPENAME for symbols that happen to be defined
1638 currently as names of types; NAME for other symbols.
1639 The caller is not constrained to care about the distinction. */
1641 std::string tmp = copy_name (yylval.sval);
1642 struct block_symbol result;
1643 const domain_enum lookup_domains[] =
1645 STRUCT_DOMAIN,
1646 VAR_DOMAIN,
1647 MODULE_DOMAIN
1649 int hextype;
1651 for (const auto &domain : lookup_domains)
1653 result = lookup_symbol (tmp.c_str (), pstate->expression_context_block,
1654 domain, NULL);
1655 if (result.symbol && result.symbol->aclass () == LOC_TYPEDEF)
1657 yylval.tsym.type = result.symbol->type ();
1658 return TYPENAME;
1661 if (result.symbol)
1662 break;
1665 yylval.tsym.type
1666 = language_lookup_primitive_type (pstate->language (),
1667 pstate->gdbarch (), tmp.c_str ());
1668 if (yylval.tsym.type != NULL)
1669 return TYPENAME;
1671 /* This is post the symbol search as symbols can hide intrinsics. Also,
1672 give Fortran intrinsics priority over C symbols. This prevents
1673 non-Fortran symbols from hiding intrinsics, for example abs. */
1674 if (!result.symbol || result.symbol->language () != language_fortran)
1675 for (const auto &intrinsic : f_intrinsics)
1677 gdb_assert (!intrinsic.case_sensitive);
1678 if (strlen (intrinsic.oper) == namelen
1679 && strncasecmp (tokstart, intrinsic.oper, namelen) == 0)
1681 yylval.opcode = intrinsic.opcode;
1682 return intrinsic.token;
1686 /* Input names that aren't symbols but ARE valid hex numbers,
1687 when the input radix permits them, can be names or numbers
1688 depending on the parse. Note we support radixes > 16 here. */
1689 if (!result.symbol
1690 && ((tokstart[0] >= 'a' && tokstart[0] < 'a' + input_radix - 10)
1691 || (tokstart[0] >= 'A' && tokstart[0] < 'A' + input_radix - 10)))
1693 YYSTYPE newlval; /* Its value is ignored. */
1694 hextype = parse_number (pstate, tokstart, namelen, 0, &newlval);
1695 if (hextype == INT)
1697 yylval.ssym.sym = result;
1698 yylval.ssym.is_a_field_of_this = false;
1699 return NAME_OR_INT;
1703 if (pstate->parse_completion && *pstate->lexptr == '\0')
1704 saw_name_at_eof = true;
1706 /* Any other kind of symbol */
1707 yylval.ssym.sym = result;
1708 yylval.ssym.is_a_field_of_this = false;
1709 return NAME;
1714 f_language::parser (struct parser_state *par_state) const
1716 /* Setting up the parser state. */
1717 scoped_restore pstate_restore = make_scoped_restore (&pstate);
1718 scoped_restore restore_yydebug = make_scoped_restore (&yydebug,
1719 par_state->debug);
1720 gdb_assert (par_state != NULL);
1721 pstate = par_state;
1722 last_was_structop = false;
1723 saw_name_at_eof = false;
1724 paren_depth = 0;
1726 struct type_stack stack;
1727 scoped_restore restore_type_stack = make_scoped_restore (&type_stack,
1728 &stack);
1730 int result = yyparse ();
1731 if (!result)
1732 pstate->set_operation (pstate->pop ());
1733 return result;
1736 static void
1737 yyerror (const char *msg)
1739 if (pstate->prev_lexptr)
1740 pstate->lexptr = pstate->prev_lexptr;
1742 error (_("A %s in expression, near `%s'."), msg, pstate->lexptr);