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