1
2 /* YACC parser for Fortran expressions, for GDB.
3 Copyright (C) 1986-2024 Free Software Foundation, Inc.
4
5 Contributed by Motorola. Adapted from the C parser by Farooq Butt
6 (fmbutt@engage.sps.mot.com).
7
8 This file is part of GDB.
9
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.
14
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.
19
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/>. */
22
23 /* This was blantantly ripped off the C expression parser, please
24 be aware of that as you look at its basic structure -FMB */
25
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.
34
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. */
42
43 %{
44
45 #include "expression.h"
46 #include "value.h"
47 #include "parser-defs.h"
48 #include "language.h"
49 #include "f-lang.h"
50 #include "block.h"
51 #include <ctype.h>
52 #include <algorithm>
53 #include "type-stack.h"
54 #include "f-exp.h"
55
56 #define parse_type(ps) builtin_type (ps->gdbarch ())
57 #define parse_f_type(ps) builtin_f_type (ps->gdbarch ())
58
59 /* Remap normal yacc parser interface names (yyparse, yylex, yyerror,
60 etc). */
61 #define GDB_YY_REMAP_PREFIX f_
62 #include "yy-remap.h"
63
64 /* The state of the parser, used internally when we are parsing the
65 expression. */
66
67 static struct parser_state *pstate = NULL;
68
69 /* Depth of parentheses. */
70 static int paren_depth;
71
72 /* The current type stack. */
73 static struct type_stack *type_stack;
74
75 int yyparse (void);
76
77 static int yylex (void);
78
79 static void yyerror (const char *);
80
81 static void growbuf_by_size (int);
82
83 static int match_string_literal (void);
84
85 static void push_kind_type (LONGEST val, struct type *type);
86
87 static struct type *convert_to_kind_type (struct type *basetype, int kind);
88
89 static void wrap_unop_intrinsic (exp_opcode opcode);
90
91 static void wrap_binop_intrinsic (exp_opcode opcode);
92
93 static void wrap_ternop_intrinsic (exp_opcode opcode);
94
95 template<typename T>
96 static void fortran_wrap2_kind (type *base_type);
97
98 template<typename T>
99 static void fortran_wrap3_kind (type *base_type);
100
101 using namespace expr;
102 %}
103
104 /* Although the yacc "value" of an expression is not used,
105 since the result is stored in the structure being created,
106 other node types do have values. */
107
108 %union
109 {
110 LONGEST lval;
111 struct {
112 LONGEST val;
113 struct type *type;
114 } typed_val;
115 struct {
116 gdb_byte val[16];
117 struct type *type;
118 } typed_val_float;
119 struct symbol *sym;
120 struct type *tval;
121 struct stoken sval;
122 struct ttype tsym;
123 struct symtoken ssym;
124 int voidval;
125 enum exp_opcode opcode;
126 struct internalvar *ivar;
127
128 struct type **tvec;
129 int *ivec;
130 }
131
132 %{
133 /* YYSTYPE gets defined by %union */
134 static int parse_number (struct parser_state *, const char *, int,
135 int, YYSTYPE *);
136 %}
137
138 %type <voidval> exp type_exp start variable
139 %type <tval> type typebase
140 %type <tvec> nonempty_typelist
141 /* %type <bval> block */
142
143 /* Fancy type parsing. */
144 %type <voidval> func_mod direct_abs_decl abs_decl
145 %type <tval> ptype
146
147 %token <typed_val> INT
148 %token <typed_val_float> FLOAT
149
150 /* Both NAME and TYPENAME tokens represent symbols in the input,
151 and both convey their data as strings.
152 But a TYPENAME is a string that happens to be defined as a typedef
153 or builtin type name (such as int or char)
154 and a NAME is any other symbol.
155 Contexts where this distinction is not important can use the
156 nonterminal "name", which matches either NAME or TYPENAME. */
157
158 %token <sval> STRING_LITERAL
159 %token <lval> BOOLEAN_LITERAL
160 %token <ssym> NAME
161 %token <tsym> TYPENAME
162 %token <voidval> COMPLETE
163 %type <sval> name
164 %type <ssym> name_not_typename
165
166 /* A NAME_OR_INT is a symbol which is not known in the symbol table,
167 but which would parse as a valid number in the current input radix.
168 E.g. "c" when input_radix==16. Depending on the parse, it will be
169 turned into a name or into a number. */
170
171 %token <ssym> NAME_OR_INT
172
173 %token SIZEOF KIND
174 %token ERROR
175
176 /* Special type cases, put in to allow the parser to distinguish different
177 legal basetypes. */
178 %token INT_S1_KEYWORD INT_S2_KEYWORD INT_KEYWORD INT_S4_KEYWORD INT_S8_KEYWORD
179 %token LOGICAL_S1_KEYWORD LOGICAL_S2_KEYWORD LOGICAL_KEYWORD LOGICAL_S4_KEYWORD
180 %token LOGICAL_S8_KEYWORD
181 %token REAL_KEYWORD REAL_S4_KEYWORD REAL_S8_KEYWORD REAL_S16_KEYWORD
182 %token COMPLEX_KEYWORD COMPLEX_S4_KEYWORD COMPLEX_S8_KEYWORD
183 %token COMPLEX_S16_KEYWORD
184 %token BOOL_AND BOOL_OR BOOL_NOT
185 %token SINGLE DOUBLE PRECISION
186 %token <lval> CHARACTER
187
188 %token <sval> DOLLAR_VARIABLE
189
190 %token <opcode> ASSIGN_MODIFY
191 %token <opcode> UNOP_INTRINSIC BINOP_INTRINSIC
192 %token <opcode> UNOP_OR_BINOP_INTRINSIC UNOP_OR_BINOP_OR_TERNOP_INTRINSIC
193
194 %left ','
195 %left ABOVE_COMMA
196 %right '=' ASSIGN_MODIFY
197 %right '?'
198 %left BOOL_OR
199 %right BOOL_NOT
200 %left BOOL_AND
201 %left '|'
202 %left '^'
203 %left '&'
204 %left EQUAL NOTEQUAL
205 %left LESSTHAN GREATERTHAN LEQ GEQ
206 %left LSH RSH
207 %left '@'
208 %left '+' '-'
209 %left '*' '/'
210 %right STARSTAR
211 %right '%'
212 %right UNARY
213 %right '('
214
215
216 %%
217
218 start : exp
219 | type_exp
220 ;
221
222 type_exp: type
223 { pstate->push_new<type_operation> ($1); }
224 ;
225
226 exp : '(' exp ')'
227 { }
228 ;
229
230 /* Expressions, not including the comma operator. */
231 exp : '*' exp %prec UNARY
232 { pstate->wrap<unop_ind_operation> (); }
233 ;
234
235 exp : '&' exp %prec UNARY
236 { pstate->wrap<unop_addr_operation> (); }
237 ;
238
239 exp : '-' exp %prec UNARY
240 { pstate->wrap<unary_neg_operation> (); }
241 ;
242
243 exp : BOOL_NOT exp %prec UNARY
244 { pstate->wrap<unary_logical_not_operation> (); }
245 ;
246
247 exp : '~' exp %prec UNARY
248 { pstate->wrap<unary_complement_operation> (); }
249 ;
250
251 exp : SIZEOF exp %prec UNARY
252 { pstate->wrap<unop_sizeof_operation> (); }
253 ;
254
255 exp : KIND '(' exp ')' %prec UNARY
256 { pstate->wrap<fortran_kind_operation> (); }
257 ;
258
259 /* No more explicit array operators, we treat everything in F77 as
260 a function call. The disambiguation as to whether we are
261 doing a subscript operation or a function call is done
262 later in eval.c. */
263
264 exp : exp '('
265 { pstate->start_arglist (); }
266 arglist ')'
267 {
268 std::vector<operation_up> args
269 = pstate->pop_vector (pstate->end_arglist ());
270 pstate->push_new<fortran_undetermined>
271 (pstate->pop (), std::move (args));
272 }
273 ;
274
275 exp : UNOP_INTRINSIC '(' exp ')'
276 {
277 wrap_unop_intrinsic ($1);
278 }
279 ;
280
281 exp : BINOP_INTRINSIC '(' exp ',' exp ')'
282 {
283 wrap_binop_intrinsic ($1);
284 }
285 ;
286
287 exp : UNOP_OR_BINOP_INTRINSIC '('
288 { pstate->start_arglist (); }
289 arglist ')'
290 {
291 const int n = pstate->end_arglist ();
292
293 switch (n)
294 {
295 case 1:
296 wrap_unop_intrinsic ($1);
297 break;
298 case 2:
299 wrap_binop_intrinsic ($1);
300 break;
301 default:
302 gdb_assert_not_reached
303 ("wrong number of arguments for intrinsics");
304 }
305 }
306
307 exp : UNOP_OR_BINOP_OR_TERNOP_INTRINSIC '('
308 { pstate->start_arglist (); }
309 arglist ')'
310 {
311 const int n = pstate->end_arglist ();
312
313 switch (n)
314 {
315 case 1:
316 wrap_unop_intrinsic ($1);
317 break;
318 case 2:
319 wrap_binop_intrinsic ($1);
320 break;
321 case 3:
322 wrap_ternop_intrinsic ($1);
323 break;
324 default:
325 gdb_assert_not_reached
326 ("wrong number of arguments for intrinsics");
327 }
328 }
329 ;
330
331 arglist :
332 ;
333
334 arglist : exp
335 { pstate->arglist_len = 1; }
336 ;
337
338 arglist : subrange
339 { pstate->arglist_len = 1; }
340 ;
341
342 arglist : arglist ',' exp %prec ABOVE_COMMA
343 { pstate->arglist_len++; }
344 ;
345
346 arglist : arglist ',' subrange %prec ABOVE_COMMA
347 { pstate->arglist_len++; }
348 ;
349
350 /* There are four sorts of subrange types in F90. */
351
352 subrange: exp ':' exp %prec ABOVE_COMMA
353 {
354 operation_up high = pstate->pop ();
355 operation_up low = pstate->pop ();
356 pstate->push_new<fortran_range_operation>
357 (RANGE_STANDARD, std::move (low),
358 std::move (high), operation_up ());
359 }
360 ;
361
362 subrange: exp ':' %prec ABOVE_COMMA
363 {
364 operation_up low = pstate->pop ();
365 pstate->push_new<fortran_range_operation>
366 (RANGE_HIGH_BOUND_DEFAULT, std::move (low),
367 operation_up (), operation_up ());
368 }
369 ;
370
371 subrange: ':' exp %prec ABOVE_COMMA
372 {
373 operation_up high = pstate->pop ();
374 pstate->push_new<fortran_range_operation>
375 (RANGE_LOW_BOUND_DEFAULT, operation_up (),
376 std::move (high), operation_up ());
377 }
378 ;
379
380 subrange: ':' %prec ABOVE_COMMA
381 {
382 pstate->push_new<fortran_range_operation>
383 (RANGE_LOW_BOUND_DEFAULT
384 | RANGE_HIGH_BOUND_DEFAULT,
385 operation_up (), operation_up (),
386 operation_up ());
387 }
388 ;
389
390 /* And each of the four subrange types can also have a stride. */
391 subrange: exp ':' exp ':' exp %prec ABOVE_COMMA
392 {
393 operation_up stride = pstate->pop ();
394 operation_up high = pstate->pop ();
395 operation_up low = pstate->pop ();
396 pstate->push_new<fortran_range_operation>
397 (RANGE_STANDARD | RANGE_HAS_STRIDE,
398 std::move (low), std::move (high),
399 std::move (stride));
400 }
401 ;
402
403 subrange: exp ':' ':' exp %prec ABOVE_COMMA
404 {
405 operation_up stride = pstate->pop ();
406 operation_up low = pstate->pop ();
407 pstate->push_new<fortran_range_operation>
408 (RANGE_HIGH_BOUND_DEFAULT
409 | RANGE_HAS_STRIDE,
410 std::move (low), operation_up (),
411 std::move (stride));
412 }
413 ;
414
415 subrange: ':' exp ':' exp %prec ABOVE_COMMA
416 {
417 operation_up stride = pstate->pop ();
418 operation_up high = pstate->pop ();
419 pstate->push_new<fortran_range_operation>
420 (RANGE_LOW_BOUND_DEFAULT
421 | RANGE_HAS_STRIDE,
422 operation_up (), std::move (high),
423 std::move (stride));
424 }
425 ;
426
427 subrange: ':' ':' exp %prec ABOVE_COMMA
428 {
429 operation_up stride = pstate->pop ();
430 pstate->push_new<fortran_range_operation>
431 (RANGE_LOW_BOUND_DEFAULT
432 | RANGE_HIGH_BOUND_DEFAULT
433 | RANGE_HAS_STRIDE,
434 operation_up (), operation_up (),
435 std::move (stride));
436 }
437 ;
438
439 complexnum: exp ',' exp
440 { }
441 ;
442
443 exp : '(' complexnum ')'
444 {
445 operation_up rhs = pstate->pop ();
446 operation_up lhs = pstate->pop ();
447 pstate->push_new<complex_operation>
448 (std::move (lhs), std::move (rhs),
449 parse_f_type (pstate)->builtin_complex_s16);
450 }
451 ;
452
453 exp : '(' type ')' exp %prec UNARY
454 {
455 pstate->push_new<unop_cast_operation>
456 (pstate->pop (), $2);
457 }
458 ;
459
460 exp : exp '%' name
461 {
462 pstate->push_new<fortran_structop_operation>
463 (pstate->pop (), copy_name ($3));
464 }
465 ;
466
467 exp : exp '%' name COMPLETE
468 {
469 structop_base_operation *op
470 = new fortran_structop_operation (pstate->pop (),
471 copy_name ($3));
472 pstate->mark_struct_expression (op);
473 pstate->push (operation_up (op));
474 }
475 ;
476
477 exp : exp '%' COMPLETE
478 {
479 structop_base_operation *op
480 = new fortran_structop_operation (pstate->pop (),
481 "");
482 pstate->mark_struct_expression (op);
483 pstate->push (operation_up (op));
484 }
485 ;
486
487 /* Binary operators in order of decreasing precedence. */
488
489 exp : exp '@' exp
490 { pstate->wrap2<repeat_operation> (); }
491 ;
492
493 exp : exp STARSTAR exp
494 { pstate->wrap2<exp_operation> (); }
495 ;
496
497 exp : exp '*' exp
498 { pstate->wrap2<mul_operation> (); }
499 ;
500
501 exp : exp '/' exp
502 { pstate->wrap2<div_operation> (); }
503 ;
504
505 exp : exp '+' exp
506 { pstate->wrap2<add_operation> (); }
507 ;
508
509 exp : exp '-' exp
510 { pstate->wrap2<sub_operation> (); }
511 ;
512
513 exp : exp LSH exp
514 { pstate->wrap2<lsh_operation> (); }
515 ;
516
517 exp : exp RSH exp
518 { pstate->wrap2<rsh_operation> (); }
519 ;
520
521 exp : exp EQUAL exp
522 { pstate->wrap2<equal_operation> (); }
523 ;
524
525 exp : exp NOTEQUAL exp
526 { pstate->wrap2<notequal_operation> (); }
527 ;
528
529 exp : exp LEQ exp
530 { pstate->wrap2<leq_operation> (); }
531 ;
532
533 exp : exp GEQ exp
534 { pstate->wrap2<geq_operation> (); }
535 ;
536
537 exp : exp LESSTHAN exp
538 { pstate->wrap2<less_operation> (); }
539 ;
540
541 exp : exp GREATERTHAN exp
542 { pstate->wrap2<gtr_operation> (); }
543 ;
544
545 exp : exp '&' exp
546 { pstate->wrap2<bitwise_and_operation> (); }
547 ;
548
549 exp : exp '^' exp
550 { pstate->wrap2<bitwise_xor_operation> (); }
551 ;
552
553 exp : exp '|' exp
554 { pstate->wrap2<bitwise_ior_operation> (); }
555 ;
556
557 exp : exp BOOL_AND exp
558 { pstate->wrap2<logical_and_operation> (); }
559 ;
560
561
562 exp : exp BOOL_OR exp
563 { pstate->wrap2<logical_or_operation> (); }
564 ;
565
566 exp : exp '=' exp
567 { pstate->wrap2<assign_operation> (); }
568 ;
569
570 exp : exp ASSIGN_MODIFY exp
571 {
572 operation_up rhs = pstate->pop ();
573 operation_up lhs = pstate->pop ();
574 pstate->push_new<assign_modify_operation>
575 ($2, std::move (lhs), std::move (rhs));
576 }
577 ;
578
579 exp : INT
580 {
581 pstate->push_new<long_const_operation>
582 ($1.type, $1.val);
583 }
584 ;
585
586 exp : NAME_OR_INT
587 { YYSTYPE val;
588 parse_number (pstate, $1.stoken.ptr,
589 $1.stoken.length, 0, &val);
590 pstate->push_new<long_const_operation>
591 (val.typed_val.type,
592 val.typed_val.val);
593 }
594 ;
595
596 exp : FLOAT
597 {
598 float_data data;
599 std::copy (std::begin ($1.val), std::end ($1.val),
600 std::begin (data));
601 pstate->push_new<float_const_operation> ($1.type, data);
602 }
603 ;
604
605 exp : variable
606 ;
607
608 exp : DOLLAR_VARIABLE
609 { pstate->push_dollar ($1); }
610 ;
611
612 exp : SIZEOF '(' type ')' %prec UNARY
613 {
614 $3 = check_typedef ($3);
615 pstate->push_new<long_const_operation>
616 (parse_f_type (pstate)->builtin_integer,
617 $3->length ());
618 }
619 ;
620
621 exp : BOOLEAN_LITERAL
622 { pstate->push_new<bool_operation> ($1); }
623 ;
624
625 exp : STRING_LITERAL
626 {
627 pstate->push_new<string_operation>
628 (copy_name ($1));
629 }
630 ;
631
632 variable: name_not_typename
633 { struct block_symbol sym = $1.sym;
634 std::string name = copy_name ($1.stoken);
635 pstate->push_symbol (name.c_str (), sym);
636 }
637 ;
638
639
640 type : ptype
641 ;
642
643 ptype : typebase
644 | typebase abs_decl
645 {
646 /* This is where the interesting stuff happens. */
647 int done = 0;
648 int array_size;
649 struct type *follow_type = $1;
650 struct type *range_type;
651
652 while (!done)
653 switch (type_stack->pop ())
654 {
655 case tp_end:
656 done = 1;
657 break;
658 case tp_pointer:
659 follow_type = lookup_pointer_type (follow_type);
660 break;
661 case tp_reference:
662 follow_type = lookup_lvalue_reference_type (follow_type);
663 break;
664 case tp_array:
665 array_size = type_stack->pop_int ();
666 if (array_size != -1)
667 {
668 struct type *idx_type
669 = parse_f_type (pstate)->builtin_integer;
670 type_allocator alloc (idx_type);
671 range_type =
672 create_static_range_type (alloc, idx_type,
673 0, array_size - 1);
674 follow_type = create_array_type (alloc,
675 follow_type,
676 range_type);
677 }
678 else
679 follow_type = lookup_pointer_type (follow_type);
680 break;
681 case tp_function:
682 follow_type = lookup_function_type (follow_type);
683 break;
684 case tp_kind:
685 {
686 int kind_val = type_stack->pop_int ();
687 follow_type
688 = convert_to_kind_type (follow_type, kind_val);
689 }
690 break;
691 }
692 $$ = follow_type;
693 }
694 ;
695
696 abs_decl: '*'
697 { type_stack->push (tp_pointer); $$ = 0; }
698 | '*' abs_decl
699 { type_stack->push (tp_pointer); $$ = $2; }
700 | '&'
701 { type_stack->push (tp_reference); $$ = 0; }
702 | '&' abs_decl
703 { type_stack->push (tp_reference); $$ = $2; }
704 | direct_abs_decl
705 ;
706
707 direct_abs_decl: '(' abs_decl ')'
708 { $$ = $2; }
709 | '(' KIND '=' INT ')'
710 { push_kind_type ($4.val, $4.type); }
711 | '*' INT
712 { push_kind_type ($2.val, $2.type); }
713 | direct_abs_decl func_mod
714 { type_stack->push (tp_function); }
715 | func_mod
716 { type_stack->push (tp_function); }
717 ;
718
719 func_mod: '(' ')'
720 { $$ = 0; }
721 | '(' nonempty_typelist ')'
722 { free ($2); $$ = 0; }
723 ;
724
725 typebase /* Implements (approximately): (type-qualifier)* type-specifier */
726 : TYPENAME
727 { $$ = $1.type; }
728 | INT_S1_KEYWORD
729 { $$ = parse_f_type (pstate)->builtin_integer_s1; }
730 | INT_S2_KEYWORD
731 { $$ = parse_f_type (pstate)->builtin_integer_s2; }
732 | INT_KEYWORD
733 { $$ = parse_f_type (pstate)->builtin_integer; }
734 | INT_S4_KEYWORD
735 { $$ = parse_f_type (pstate)->builtin_integer; }
736 | INT_S8_KEYWORD
737 { $$ = parse_f_type (pstate)->builtin_integer_s8; }
738 | CHARACTER
739 { $$ = parse_f_type (pstate)->builtin_character; }
740 | LOGICAL_S1_KEYWORD
741 { $$ = parse_f_type (pstate)->builtin_logical_s1; }
742 | LOGICAL_S2_KEYWORD
743 { $$ = parse_f_type (pstate)->builtin_logical_s2; }
744 | LOGICAL_KEYWORD
745 { $$ = parse_f_type (pstate)->builtin_logical; }
746 | LOGICAL_S4_KEYWORD
747 { $$ = parse_f_type (pstate)->builtin_logical; }
748 | LOGICAL_S8_KEYWORD
749 { $$ = parse_f_type (pstate)->builtin_logical_s8; }
750 | REAL_KEYWORD
751 { $$ = parse_f_type (pstate)->builtin_real; }
752 | REAL_S4_KEYWORD
753 { $$ = parse_f_type (pstate)->builtin_real; }
754 | REAL_S8_KEYWORD
755 { $$ = parse_f_type (pstate)->builtin_real_s8; }
756 | REAL_S16_KEYWORD
757 { $$ = parse_f_type (pstate)->builtin_real_s16; }
758 | COMPLEX_KEYWORD
759 { $$ = parse_f_type (pstate)->builtin_complex; }
760 | COMPLEX_S4_KEYWORD
761 { $$ = parse_f_type (pstate)->builtin_complex; }
762 | COMPLEX_S8_KEYWORD
763 { $$ = parse_f_type (pstate)->builtin_complex_s8; }
764 | COMPLEX_S16_KEYWORD
765 { $$ = parse_f_type (pstate)->builtin_complex_s16; }
766 | SINGLE PRECISION
767 { $$ = parse_f_type (pstate)->builtin_real;}
768 | DOUBLE PRECISION
769 { $$ = parse_f_type (pstate)->builtin_real_s8;}
770 | SINGLE COMPLEX_KEYWORD
771 { $$ = parse_f_type (pstate)->builtin_complex;}
772 | DOUBLE COMPLEX_KEYWORD
773 { $$ = parse_f_type (pstate)->builtin_complex_s8;}
774 ;
775
776 nonempty_typelist
777 : type
778 { $$ = (struct type **) malloc (sizeof (struct type *) * 2);
779 $<ivec>$[0] = 1; /* Number of types in vector */
780 $$[1] = $1;
781 }
782 | nonempty_typelist ',' type
783 { int len = sizeof (struct type *) * (++($<ivec>1[0]) + 1);
784 $$ = (struct type **) realloc ((char *) $1, len);
785 $$[$<ivec>$[0]] = $3;
786 }
787 ;
788
789 name
790 : NAME
791 { $$ = $1.stoken; }
792 | TYPENAME
793 { $$ = $1.stoken; }
794 ;
795
796 name_not_typename : NAME
797 /* These would be useful if name_not_typename was useful, but it is just
798 a fake for "variable", so these cause reduce/reduce conflicts because
799 the parser can't tell whether NAME_OR_INT is a name_not_typename (=variable,
800 =exp) or just an exp. If name_not_typename was ever used in an lvalue
801 context where only a name could occur, this might be useful.
802 | NAME_OR_INT
803 */
804 ;
805
806 %%
807
808 /* Called to match intrinsic function calls with one argument to their
809 respective implementation and push the operation. */
810
811 static void
812 wrap_unop_intrinsic (exp_opcode code)
813 {
814 switch (code)
815 {
816 case UNOP_ABS:
817 pstate->wrap<fortran_abs_operation> ();
818 break;
819 case FORTRAN_FLOOR:
820 pstate->wrap<fortran_floor_operation_1arg> ();
821 break;
822 case FORTRAN_CEILING:
823 pstate->wrap<fortran_ceil_operation_1arg> ();
824 break;
825 case UNOP_FORTRAN_ALLOCATED:
826 pstate->wrap<fortran_allocated_operation> ();
827 break;
828 case UNOP_FORTRAN_RANK:
829 pstate->wrap<fortran_rank_operation> ();
830 break;
831 case UNOP_FORTRAN_SHAPE:
832 pstate->wrap<fortran_array_shape_operation> ();
833 break;
834 case UNOP_FORTRAN_LOC:
835 pstate->wrap<fortran_loc_operation> ();
836 break;
837 case FORTRAN_ASSOCIATED:
838 pstate->wrap<fortran_associated_1arg> ();
839 break;
840 case FORTRAN_ARRAY_SIZE:
841 pstate->wrap<fortran_array_size_1arg> ();
842 break;
843 case FORTRAN_CMPLX:
844 pstate->wrap<fortran_cmplx_operation_1arg> ();
845 break;
846 case FORTRAN_LBOUND:
847 case FORTRAN_UBOUND:
848 pstate->push_new<fortran_bound_1arg> (code, pstate->pop ());
849 break;
850 default:
851 gdb_assert_not_reached ("unhandled intrinsic");
852 }
853 }
854
855 /* Called to match intrinsic function calls with two arguments to their
856 respective implementation and push the operation. */
857
858 static void
wrap_binop_intrinsic(exp_opcode code)859 wrap_binop_intrinsic (exp_opcode code)
860 {
861 switch (code)
862 {
863 case FORTRAN_FLOOR:
864 fortran_wrap2_kind<fortran_floor_operation_2arg>
865 (parse_f_type (pstate)->builtin_integer);
866 break;
867 case FORTRAN_CEILING:
868 fortran_wrap2_kind<fortran_ceil_operation_2arg>
869 (parse_f_type (pstate)->builtin_integer);
870 break;
871 case BINOP_MOD:
872 pstate->wrap2<fortran_mod_operation> ();
873 break;
874 case BINOP_FORTRAN_MODULO:
875 pstate->wrap2<fortran_modulo_operation> ();
876 break;
877 case FORTRAN_CMPLX:
878 pstate->wrap2<fortran_cmplx_operation_2arg> ();
879 break;
880 case FORTRAN_ASSOCIATED:
881 pstate->wrap2<fortran_associated_2arg> ();
882 break;
883 case FORTRAN_ARRAY_SIZE:
884 pstate->wrap2<fortran_array_size_2arg> ();
885 break;
886 case FORTRAN_LBOUND:
887 case FORTRAN_UBOUND:
888 {
889 operation_up arg2 = pstate->pop ();
890 operation_up arg1 = pstate->pop ();
891 pstate->push_new<fortran_bound_2arg> (code, std::move (arg1),
892 std::move (arg2));
893 }
894 break;
895 default:
896 gdb_assert_not_reached ("unhandled intrinsic");
897 }
898 }
899
900 /* Called to match intrinsic function calls with three arguments to their
901 respective implementation and push the operation. */
902
903 static void
wrap_ternop_intrinsic(exp_opcode code)904 wrap_ternop_intrinsic (exp_opcode code)
905 {
906 switch (code)
907 {
908 case FORTRAN_LBOUND:
909 case FORTRAN_UBOUND:
910 {
911 operation_up kind_arg = pstate->pop ();
912 operation_up arg2 = pstate->pop ();
913 operation_up arg1 = pstate->pop ();
914
915 value *val = kind_arg->evaluate (nullptr, pstate->expout.get (),
916 EVAL_AVOID_SIDE_EFFECTS);
917 gdb_assert (val != nullptr);
918
919 type *follow_type
920 = convert_to_kind_type (parse_f_type (pstate)->builtin_integer,
921 value_as_long (val));
922
923 pstate->push_new<fortran_bound_3arg> (code, std::move (arg1),
924 std::move (arg2), follow_type);
925 }
926 break;
927 case FORTRAN_ARRAY_SIZE:
928 fortran_wrap3_kind<fortran_array_size_3arg>
929 (parse_f_type (pstate)->builtin_integer);
930 break;
931 case FORTRAN_CMPLX:
932 fortran_wrap3_kind<fortran_cmplx_operation_3arg>
933 (parse_f_type (pstate)->builtin_complex);
934 break;
935 default:
936 gdb_assert_not_reached ("unhandled intrinsic");
937 }
938 }
939
940 /* A helper that pops two operations (similar to wrap2), evaluates the last one
941 assuming it is a kind parameter, and wraps them in some other operation
942 pushing it to the stack. */
943
944 template<typename T>
945 static void
fortran_wrap2_kind(type * base_type)946 fortran_wrap2_kind (type *base_type)
947 {
948 operation_up kind_arg = pstate->pop ();
949 operation_up arg = pstate->pop ();
950
951 value *val = kind_arg->evaluate (nullptr, pstate->expout.get (),
952 EVAL_AVOID_SIDE_EFFECTS);
953 gdb_assert (val != nullptr);
954
955 type *follow_type = convert_to_kind_type (base_type, value_as_long (val));
956
957 pstate->push_new<T> (std::move (arg), follow_type);
958 }
959
960 /* A helper that pops three operations, evaluates the last one assuming it is a
961 kind parameter, and wraps them in some other operation pushing it to the
962 stack. */
963
964 template<typename T>
965 static void
fortran_wrap3_kind(type * base_type)966 fortran_wrap3_kind (type *base_type)
967 {
968 operation_up kind_arg = pstate->pop ();
969 operation_up arg2 = pstate->pop ();
970 operation_up arg1 = pstate->pop ();
971
972 value *val = kind_arg->evaluate (nullptr, pstate->expout.get (),
973 EVAL_AVOID_SIDE_EFFECTS);
974 gdb_assert (val != nullptr);
975
976 type *follow_type = convert_to_kind_type (base_type, value_as_long (val));
977
978 pstate->push_new<T> (std::move (arg1), std::move (arg2), follow_type);
979 }
980
981 /* Take care of parsing a number (anything that starts with a digit).
982 Set yylval and return the token type; update lexptr.
983 LEN is the number of characters in it. */
984
985 /*** Needs some error checking for the float case ***/
986
987 static int
parse_number(struct parser_state * par_state,const char * p,int len,int parsed_float,YYSTYPE * putithere)988 parse_number (struct parser_state *par_state,
989 const char *p, int len, int parsed_float, YYSTYPE *putithere)
990 {
991 ULONGEST n = 0;
992 ULONGEST prevn = 0;
993 int c;
994 int base = input_radix;
995 int unsigned_p = 0;
996 int long_p = 0;
997 ULONGEST high_bit;
998 struct type *signed_type;
999 struct type *unsigned_type;
1000
1001 if (parsed_float)
1002 {
1003 /* It's a float since it contains a point or an exponent. */
1004 /* [dD] is not understood as an exponent by parse_float,
1005 change it to 'e'. */
1006 char *tmp, *tmp2;
1007
1008 tmp = xstrdup (p);
1009 for (tmp2 = tmp; *tmp2; ++tmp2)
1010 if (*tmp2 == 'd' || *tmp2 == 'D')
1011 *tmp2 = 'e';
1012
1013 /* FIXME: Should this use different types? */
1014 putithere->typed_val_float.type = parse_f_type (pstate)->builtin_real_s8;
1015 bool parsed = parse_float (tmp, len,
1016 putithere->typed_val_float.type,
1017 putithere->typed_val_float.val);
1018 free (tmp);
1019 return parsed? FLOAT : ERROR;
1020 }
1021
1022 /* Handle base-switching prefixes 0x, 0t, 0d, 0 */
1023 if (p[0] == '0' && len > 1)
1024 switch (p[1])
1025 {
1026 case 'x':
1027 case 'X':
1028 if (len >= 3)
1029 {
1030 p += 2;
1031 base = 16;
1032 len -= 2;
1033 }
1034 break;
1035
1036 case 't':
1037 case 'T':
1038 case 'd':
1039 case 'D':
1040 if (len >= 3)
1041 {
1042 p += 2;
1043 base = 10;
1044 len -= 2;
1045 }
1046 break;
1047
1048 default:
1049 base = 8;
1050 break;
1051 }
1052
1053 while (len-- > 0)
1054 {
1055 c = *p++;
1056 if (isupper (c))
1057 c = tolower (c);
1058 if (len == 0 && c == 'l')
1059 long_p = 1;
1060 else if (len == 0 && c == 'u')
1061 unsigned_p = 1;
1062 else
1063 {
1064 int i;
1065 if (c >= '0' && c <= '9')
1066 i = c - '0';
1067 else if (c >= 'a' && c <= 'f')
1068 i = c - 'a' + 10;
1069 else
1070 return ERROR; /* Char not a digit */
1071 if (i >= base)
1072 return ERROR; /* Invalid digit in this base */
1073 n *= base;
1074 n += i;
1075 }
1076 /* Test for overflow. */
1077 if (prevn == 0 && n == 0)
1078 ;
1079 else if (RANGE_CHECK && prevn >= n)
1080 range_error (_("Overflow on numeric constant."));
1081 prevn = n;
1082 }
1083
1084 /* If the number is too big to be an int, or it's got an l suffix
1085 then it's a long. Work out if this has to be a long by
1086 shifting right and seeing if anything remains, and the
1087 target int size is different to the target long size.
1088
1089 In the expression below, we could have tested
1090 (n >> gdbarch_int_bit (parse_gdbarch))
1091 to see if it was zero,
1092 but too many compilers warn about that, when ints and longs
1093 are the same size. So we shift it twice, with fewer bits
1094 each time, for the same result. */
1095
1096 int bits_available;
1097 if ((gdbarch_int_bit (par_state->gdbarch ())
1098 != gdbarch_long_bit (par_state->gdbarch ())
1099 && ((n >> 2)
1100 >> (gdbarch_int_bit (par_state->gdbarch ())-2))) /* Avoid
1101 shift warning */
1102 || long_p)
1103 {
1104 bits_available = gdbarch_long_bit (par_state->gdbarch ());
1105 unsigned_type = parse_type (par_state)->builtin_unsigned_long;
1106 signed_type = parse_type (par_state)->builtin_long;
1107 }
1108 else
1109 {
1110 bits_available = gdbarch_int_bit (par_state->gdbarch ());
1111 unsigned_type = parse_type (par_state)->builtin_unsigned_int;
1112 signed_type = parse_type (par_state)->builtin_int;
1113 }
1114 high_bit = ((ULONGEST)1) << (bits_available - 1);
1115
1116 if (RANGE_CHECK
1117 && ((n >> 2) >> (bits_available - 2)))
1118 range_error (_("Overflow on numeric constant."));
1119
1120 putithere->typed_val.val = n;
1121
1122 /* If the high bit of the worked out type is set then this number
1123 has to be unsigned. */
1124
1125 if (unsigned_p || (n & high_bit))
1126 putithere->typed_val.type = unsigned_type;
1127 else
1128 putithere->typed_val.type = signed_type;
1129
1130 return INT;
1131 }
1132
1133 /* Called to setup the type stack when we encounter a '(kind=N)' type
1134 modifier, performs some bounds checking on 'N' and then pushes this to
1135 the type stack followed by the 'tp_kind' marker. */
1136 static void
push_kind_type(LONGEST val,struct type * type)1137 push_kind_type (LONGEST val, struct type *type)
1138 {
1139 int ival;
1140
1141 if (type->is_unsigned ())
1142 {
1143 ULONGEST uval = static_cast <ULONGEST> (val);
1144 if (uval > INT_MAX)
1145 error (_("kind value out of range"));
1146 ival = static_cast <int> (uval);
1147 }
1148 else
1149 {
1150 if (val > INT_MAX || val < 0)
1151 error (_("kind value out of range"));
1152 ival = static_cast <int> (val);
1153 }
1154
1155 type_stack->push (ival);
1156 type_stack->push (tp_kind);
1157 }
1158
1159 /* Called when a type has a '(kind=N)' modifier after it, for example
1160 'character(kind=1)'. The BASETYPE is the type described by 'character'
1161 in our example, and KIND is the integer '1'. This function returns a
1162 new type that represents the basetype of a specific kind. */
1163 static struct type *
convert_to_kind_type(struct type * basetype,int kind)1164 convert_to_kind_type (struct type *basetype, int kind)
1165 {
1166 if (basetype == parse_f_type (pstate)->builtin_character)
1167 {
1168 /* Character of kind 1 is a special case, this is the same as the
1169 base character type. */
1170 if (kind == 1)
1171 return parse_f_type (pstate)->builtin_character;
1172 }
1173 else if (basetype == parse_f_type (pstate)->builtin_complex)
1174 {
1175 if (kind == 4)
1176 return parse_f_type (pstate)->builtin_complex;
1177 else if (kind == 8)
1178 return parse_f_type (pstate)->builtin_complex_s8;
1179 else if (kind == 16)
1180 return parse_f_type (pstate)->builtin_complex_s16;
1181 }
1182 else if (basetype == parse_f_type (pstate)->builtin_real)
1183 {
1184 if (kind == 4)
1185 return parse_f_type (pstate)->builtin_real;
1186 else if (kind == 8)
1187 return parse_f_type (pstate)->builtin_real_s8;
1188 else if (kind == 16)
1189 return parse_f_type (pstate)->builtin_real_s16;
1190 }
1191 else if (basetype == parse_f_type (pstate)->builtin_logical)
1192 {
1193 if (kind == 1)
1194 return parse_f_type (pstate)->builtin_logical_s1;
1195 else if (kind == 2)
1196 return parse_f_type (pstate)->builtin_logical_s2;
1197 else if (kind == 4)
1198 return parse_f_type (pstate)->builtin_logical;
1199 else if (kind == 8)
1200 return parse_f_type (pstate)->builtin_logical_s8;
1201 }
1202 else if (basetype == parse_f_type (pstate)->builtin_integer)
1203 {
1204 if (kind == 1)
1205 return parse_f_type (pstate)->builtin_integer_s1;
1206 else if (kind == 2)
1207 return parse_f_type (pstate)->builtin_integer_s2;
1208 else if (kind == 4)
1209 return parse_f_type (pstate)->builtin_integer;
1210 else if (kind == 8)
1211 return parse_f_type (pstate)->builtin_integer_s8;
1212 }
1213
1214 error (_("unsupported kind %d for type %s"),
1215 kind, TYPE_SAFE_NAME (basetype));
1216
1217 /* Should never get here. */
1218 return nullptr;
1219 }
1220
1221 struct f_token
1222 {
1223 /* The string to match against. */
1224 const char *oper;
1225
1226 /* The lexer token to return. */
1227 int token;
1228
1229 /* The expression opcode to embed within the token. */
1230 enum exp_opcode opcode;
1231
1232 /* When this is true the string in OPER is matched exactly including
1233 case, when this is false OPER is matched case insensitively. */
1234 bool case_sensitive;
1235 };
1236
1237 /* List of Fortran operators. */
1238
1239 static const struct f_token fortran_operators[] =
1240 {
1241 { ".and.", BOOL_AND, OP_NULL, false },
1242 { ".or.", BOOL_OR, OP_NULL, false },
1243 { ".not.", BOOL_NOT, OP_NULL, false },
1244 { ".eq.", EQUAL, OP_NULL, false },
1245 { ".eqv.", EQUAL, OP_NULL, false },
1246 { ".neqv.", NOTEQUAL, OP_NULL, false },
1247 { ".xor.", NOTEQUAL, OP_NULL, false },
1248 { "==", EQUAL, OP_NULL, false },
1249 { ".ne.", NOTEQUAL, OP_NULL, false },
1250 { "/=", NOTEQUAL, OP_NULL, false },
1251 { ".le.", LEQ, OP_NULL, false },
1252 { "<=", LEQ, OP_NULL, false },
1253 { ".ge.", GEQ, OP_NULL, false },
1254 { ">=", GEQ, OP_NULL, false },
1255 { ".gt.", GREATERTHAN, OP_NULL, false },
1256 { ">", GREATERTHAN, OP_NULL, false },
1257 { ".lt.", LESSTHAN, OP_NULL, false },
1258 { "<", LESSTHAN, OP_NULL, false },
1259 { "**", STARSTAR, BINOP_EXP, false },
1260 };
1261
1262 /* Holds the Fortran representation of a boolean, and the integer value we
1263 substitute in when one of the matching strings is parsed. */
1264 struct f77_boolean_val
1265 {
1266 /* The string representing a Fortran boolean. */
1267 const char *name;
1268
1269 /* The integer value to replace it with. */
1270 int value;
1271 };
1272
1273 /* The set of Fortran booleans. These are matched case insensitively. */
1274 static const struct f77_boolean_val boolean_values[] =
1275 {
1276 { ".true.", 1 },
1277 { ".false.", 0 }
1278 };
1279
1280 static const struct f_token f_intrinsics[] =
1281 {
1282 /* The following correspond to actual functions in Fortran and are case
1283 insensitive. */
1284 { "kind", KIND, OP_NULL, false },
1285 { "abs", UNOP_INTRINSIC, UNOP_ABS, false },
1286 { "mod", BINOP_INTRINSIC, BINOP_MOD, false },
1287 { "floor", UNOP_OR_BINOP_INTRINSIC, FORTRAN_FLOOR, false },
1288 { "ceiling", UNOP_OR_BINOP_INTRINSIC, FORTRAN_CEILING, false },
1289 { "modulo", BINOP_INTRINSIC, BINOP_FORTRAN_MODULO, false },
1290 { "cmplx", UNOP_OR_BINOP_OR_TERNOP_INTRINSIC, FORTRAN_CMPLX, false },
1291 { "lbound", UNOP_OR_BINOP_OR_TERNOP_INTRINSIC, FORTRAN_LBOUND, false },
1292 { "ubound", UNOP_OR_BINOP_OR_TERNOP_INTRINSIC, FORTRAN_UBOUND, false },
1293 { "allocated", UNOP_INTRINSIC, UNOP_FORTRAN_ALLOCATED, false },
1294 { "associated", UNOP_OR_BINOP_INTRINSIC, FORTRAN_ASSOCIATED, false },
1295 { "rank", UNOP_INTRINSIC, UNOP_FORTRAN_RANK, false },
1296 { "size", UNOP_OR_BINOP_OR_TERNOP_INTRINSIC, FORTRAN_ARRAY_SIZE, false },
1297 { "shape", UNOP_INTRINSIC, UNOP_FORTRAN_SHAPE, false },
1298 { "loc", UNOP_INTRINSIC, UNOP_FORTRAN_LOC, false },
1299 { "sizeof", SIZEOF, OP_NULL, false },
1300 };
1301
1302 static const f_token f_keywords[] =
1303 {
1304 /* Historically these have always been lowercase only in GDB. */
1305 { "character", CHARACTER, OP_NULL, true },
1306 { "complex", COMPLEX_KEYWORD, OP_NULL, true },
1307 { "complex_4", COMPLEX_S4_KEYWORD, OP_NULL, true },
1308 { "complex_8", COMPLEX_S8_KEYWORD, OP_NULL, true },
1309 { "complex_16", COMPLEX_S16_KEYWORD, OP_NULL, true },
1310 { "integer_1", INT_S1_KEYWORD, OP_NULL, true },
1311 { "integer_2", INT_S2_KEYWORD, OP_NULL, true },
1312 { "integer_4", INT_S4_KEYWORD, OP_NULL, true },
1313 { "integer", INT_KEYWORD, OP_NULL, true },
1314 { "integer_8", INT_S8_KEYWORD, OP_NULL, true },
1315 { "logical_1", LOGICAL_S1_KEYWORD, OP_NULL, true },
1316 { "logical_2", LOGICAL_S2_KEYWORD, OP_NULL, true },
1317 { "logical", LOGICAL_KEYWORD, OP_NULL, true },
1318 { "logical_4", LOGICAL_S4_KEYWORD, OP_NULL, true },
1319 { "logical_8", LOGICAL_S8_KEYWORD, OP_NULL, true },
1320 { "real", REAL_KEYWORD, OP_NULL, true },
1321 { "real_4", REAL_S4_KEYWORD, OP_NULL, true },
1322 { "real_8", REAL_S8_KEYWORD, OP_NULL, true },
1323 { "real_16", REAL_S16_KEYWORD, OP_NULL, true },
1324 { "single", SINGLE, OP_NULL, true },
1325 { "double", DOUBLE, OP_NULL, true },
1326 { "precision", PRECISION, OP_NULL, true },
1327 };
1328
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 */
1332
1333 static char *tempbuf; /* Current buffer contents */
1334 static int tempbufsize; /* Size of allocated buffer */
1335 static int tempbufindex; /* Current index into buffer */
1336
1337 #define GROWBY_MIN_SIZE 64 /* Minimum amount to grow buffer by */
1338
1339 #define CHECKBUF(size) \
1340 do { \
1341 if (tempbufindex + (size) >= tempbufsize) \
1342 { \
1343 growbuf_by_size (size); \
1344 } \
1345 } while (0);
1346
1347
1348 /* Grow the static temp buffer if necessary, including allocating the
1349 first one on demand. */
1350
1351 static void
growbuf_by_size(int count)1352 growbuf_by_size (int count)
1353 {
1354 int growby;
1355
1356 growby = std::max (count, GROWBY_MIN_SIZE);
1357 tempbufsize += growby;
1358 if (tempbuf == NULL)
1359 tempbuf = (char *) malloc (tempbufsize);
1360 else
1361 tempbuf = (char *) realloc (tempbuf, tempbufsize);
1362 }
1363
1364 /* Blatantly ripped off from ch-exp.y. This routine recognizes F77
1365 string-literals.
1366
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') */
1372
1373 static int
match_string_literal(void)1374 match_string_literal (void)
1375 {
1376 const char *tokptr = pstate->lexptr;
1377
1378 for (tempbufindex = 0, tokptr++; *tokptr != '\0'; tokptr++)
1379 {
1380 CHECKBUF (1);
1381 if (*tokptr == *pstate->lexptr)
1382 {
1383 if (*(tokptr + 1) == *pstate->lexptr)
1384 tokptr++;
1385 else
1386 break;
1387 }
1388 tempbuf[tempbufindex++] = *tokptr;
1389 }
1390 if (*tokptr == '\0' /* no terminator */
1391 || tempbufindex == 0) /* no string */
1392 return 0;
1393 else
1394 {
1395 tempbuf[tempbufindex] = '\0';
1396 yylval.sval.ptr = tempbuf;
1397 yylval.sval.length = tempbufindex;
1398 pstate->lexptr = ++tokptr;
1399 return STRING_LITERAL;
1400 }
1401 }
1402
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;
1407
1408 /* This is set if the previously-returned token was a structure
1409 operator '%'. */
1410 static bool last_was_structop;
1411
1412 /* Read one token, getting characters through lexptr. */
1413
1414 static int
yylex(void)1415 yylex (void)
1416 {
1417 int c;
1418 int namelen;
1419 unsigned int token;
1420 const char *tokstart;
1421 bool saw_structop = last_was_structop;
1422
1423 last_was_structop = false;
1424
1425 retry:
1426
1427 pstate->prev_lexptr = pstate->lexptr;
1428
1429 tokstart = pstate->lexptr;
1430
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. */
1433
1434 if (*pstate->lexptr == '.')
1435 {
1436 for (const auto &candidate : boolean_values)
1437 {
1438 if (strncasecmp (tokstart, candidate.name,
1439 strlen (candidate.name)) == 0)
1440 {
1441 pstate->lexptr += strlen (candidate.name);
1442 yylval.lval = candidate.value;
1443 return BOOLEAN_LITERAL;
1444 }
1445 }
1446 }
1447
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)
1452 {
1453 gdb_assert (!candidate.case_sensitive);
1454 pstate->lexptr += strlen (candidate.oper);
1455 yylval.opcode = candidate.opcode;
1456 return candidate.token;
1457 }
1458
1459 switch (c = *tokstart)
1460 {
1461 case 0:
1462 if (saw_name_at_eof)
1463 {
1464 saw_name_at_eof = false;
1465 return COMPLETE;
1466 }
1467 else if (pstate->parse_completion && saw_structop)
1468 return COMPLETE;
1469 return 0;
1470
1471 case ' ':
1472 case '\t':
1473 case '\n':
1474 pstate->lexptr++;
1475 goto retry;
1476
1477 case '\'':
1478 token = match_string_literal ();
1479 if (token != 0)
1480 return (token);
1481 break;
1482
1483 case '(':
1484 paren_depth++;
1485 pstate->lexptr++;
1486 return c;
1487
1488 case ')':
1489 if (paren_depth == 0)
1490 return 0;
1491 paren_depth--;
1492 pstate->lexptr++;
1493 return c;
1494
1495 case ',':
1496 if (pstate->comma_terminates && paren_depth == 0)
1497 return 0;
1498 pstate->lexptr++;
1499 return c;
1500
1501 case '.':
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. */
1505 [[fallthrough]];
1506
1507 case '0':
1508 case '1':
1509 case '2':
1510 case '3':
1511 case '4':
1512 case '5':
1513 case '6':
1514 case '7':
1515 case '8':
1516 case '9':
1517 {
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;
1522
1523 if (c == '0' && (p[1] == 'x' || p[1] == 'X'))
1524 {
1525 p += 2;
1526 hex = 1;
1527 }
1528 else if (c == '0' && (p[1]=='t' || p[1]=='T'
1529 || p[1]=='d' || p[1]=='D'))
1530 {
1531 p += 2;
1532 hex = 0;
1533 }
1534
1535 for (;; ++p)
1536 {
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 == '.')
1542 got_dot = 1;
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
1547 number. */
1548 continue;
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')))
1554 break;
1555 }
1556 toktype = parse_number (pstate, tokstart, p - tokstart,
1557 got_dot|got_e|got_d,
1558 &yylval);
1559 if (toktype == ERROR)
1560 error (_("Invalid number \"%.*s\"."), (int) (p - tokstart),
1561 tokstart);
1562 pstate->lexptr = p;
1563 return toktype;
1564 }
1565
1566 case '%':
1567 last_was_structop = true;
1568 [[fallthrough]];
1569 case '+':
1570 case '-':
1571 case '*':
1572 case '/':
1573 case '|':
1574 case '&':
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 symbol:
1589 pstate->lexptr++;
1590 return c;
1591 }
1592
1593 if (!(c == '_' || c == '$' || c ==':'
1594 || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')))
1595 /* We must have come across a bad character (e.g. ';'). */
1596 error (_("Invalid character '%c' in expression."), c);
1597
1598 namelen = 0;
1599 for (c = tokstart[namelen];
1600 (c == '_' || c == '$' || c == ':' || (c >= '0' && c <= '9')
1601 || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'));
1602 c = tokstart[++namelen]);
1603
1604 /* The token "if" terminates the expression and is NOT
1605 removed from the input stream. */
1606
1607 if (namelen == 2 && tokstart[0] == 'i' && tokstart[1] == 'f')
1608 return 0;
1609
1610 pstate->lexptr += namelen;
1611
1612 /* Catch specific keywords. */
1613
1614 for (const auto &keyword : f_keywords)
1615 if (strlen (keyword.oper) == namelen
1616 && ((!keyword.case_sensitive
1617 && strncasecmp (tokstart, keyword.oper, namelen) == 0)
1618 || (keyword.case_sensitive
1619 && strncmp (tokstart, keyword.oper, namelen) == 0)))
1620 {
1621 yylval.opcode = keyword.opcode;
1622 return keyword.token;
1623 }
1624
1625 yylval.sval.ptr = tokstart;
1626 yylval.sval.length = namelen;
1627
1628 if (*tokstart == '$')
1629 return DOLLAR_VARIABLE;
1630
1631 /* Use token-type TYPENAME for symbols that happen to be defined
1632 currently as names of types; NAME for other symbols.
1633 The caller is not constrained to care about the distinction. */
1634 {
1635 std::string tmp = copy_name (yylval.sval);
1636 struct block_symbol result;
1637 const domain_search_flags lookup_domains[] =
1638 {
1639 SEARCH_STRUCT_DOMAIN,
1640 SEARCH_VFT,
1641 SEARCH_MODULE_DOMAIN
1642 };
1643 int hextype;
1644
1645 for (const auto &domain : lookup_domains)
1646 {
1647 result = lookup_symbol (tmp.c_str (), pstate->expression_context_block,
1648 domain, NULL);
1649 if (result.symbol && result.symbol->aclass () == LOC_TYPEDEF)
1650 {
1651 yylval.tsym.type = result.symbol->type ();
1652 return TYPENAME;
1653 }
1654
1655 if (result.symbol)
1656 break;
1657 }
1658
1659 yylval.tsym.type
1660 = language_lookup_primitive_type (pstate->language (),
1661 pstate->gdbarch (), tmp.c_str ());
1662 if (yylval.tsym.type != NULL)
1663 return TYPENAME;
1664
1665 /* This is post the symbol search as symbols can hide intrinsics. Also,
1666 give Fortran intrinsics priority over C symbols. This prevents
1667 non-Fortran symbols from hiding intrinsics, for example abs. */
1668 if (!result.symbol || result.symbol->language () != language_fortran)
1669 for (const auto &intrinsic : f_intrinsics)
1670 {
1671 gdb_assert (!intrinsic.case_sensitive);
1672 if (strlen (intrinsic.oper) == namelen
1673 && strncasecmp (tokstart, intrinsic.oper, namelen) == 0)
1674 {
1675 yylval.opcode = intrinsic.opcode;
1676 return intrinsic.token;
1677 }
1678 }
1679
1680 /* Input names that aren't symbols but ARE valid hex numbers,
1681 when the input radix permits them, can be names or numbers
1682 depending on the parse. Note we support radixes > 16 here. */
1683 if (!result.symbol
1684 && ((tokstart[0] >= 'a' && tokstart[0] < 'a' + input_radix - 10)
1685 || (tokstart[0] >= 'A' && tokstart[0] < 'A' + input_radix - 10)))
1686 {
1687 YYSTYPE newlval; /* Its value is ignored. */
1688 hextype = parse_number (pstate, tokstart, namelen, 0, &newlval);
1689 if (hextype == INT)
1690 {
1691 yylval.ssym.sym = result;
1692 yylval.ssym.is_a_field_of_this = false;
1693 return NAME_OR_INT;
1694 }
1695 }
1696
1697 if (pstate->parse_completion && *pstate->lexptr == '\0')
1698 saw_name_at_eof = true;
1699
1700 /* Any other kind of symbol */
1701 yylval.ssym.sym = result;
1702 yylval.ssym.is_a_field_of_this = false;
1703 return NAME;
1704 }
1705 }
1706
1707 int
parser(struct parser_state * par_state)1708 f_language::parser (struct parser_state *par_state) const
1709 {
1710 /* Setting up the parser state. */
1711 scoped_restore pstate_restore = make_scoped_restore (&pstate);
1712 scoped_restore restore_yydebug = make_scoped_restore (&yydebug,
1713 par_state->debug);
1714 gdb_assert (par_state != NULL);
1715 pstate = par_state;
1716 last_was_structop = false;
1717 saw_name_at_eof = false;
1718 paren_depth = 0;
1719
1720 struct type_stack stack;
1721 scoped_restore restore_type_stack = make_scoped_restore (&type_stack,
1722 &stack);
1723
1724 int result = yyparse ();
1725 if (!result)
1726 pstate->set_operation (pstate->pop ());
1727 return result;
1728 }
1729
1730 static void
yyerror(const char * msg)1731 yyerror (const char *msg)
1732 {
1733 pstate->parse_error (msg);
1734 }
1735