1/* YACC parser for Fortran expressions, for GDB. 2 Copyright 1986, 1989, 1990, 1991, 1993, 1994, 1995, 1996, 2000, 2001 3 Free Software Foundation, Inc. 4 5 Contributed by Motorola. Adapted from the C parser by Farooq Butt 6 (fmbutt@engage.sps.mot.com). 7 8This file is part of GDB. 9 10This program is free software; you can redistribute it and/or modify 11it under the terms of the GNU General Public License as published by 12the Free Software Foundation; either version 2 of the License, or 13(at your option) any later version. 14 15This program is distributed in the hope that it will be useful, 16but WITHOUT ANY WARRANTY; without even the implied warranty of 17MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 18GNU General Public License for more details. 19 20You should have received a copy of the GNU General Public License 21along with this program; if not, write to the Free Software 22Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ 23 24/* This was blantantly ripped off the C expression parser, please 25 be aware of that as you look at its basic structure -FMB */ 26 27/* Parse a F77 expression from text in a string, 28 and return the result as a struct expression pointer. 29 That structure contains arithmetic operations in reverse polish, 30 with constants represented by operations that are followed by special data. 31 See expression.h for the details of the format. 32 What is important here is that it can be built up sequentially 33 during the process of parsing; the lower levels of the tree always 34 come first in the result. 35 36 Note that malloc's and realloc's in this file are transformed to 37 xmalloc and xrealloc respectively by the same sed command in the 38 makefile that remaps any other malloc/realloc inserted by the parser 39 generator. Doing this with #defines and trying to control the interaction 40 with include files (<malloc.h> and <stdlib.h> for example) just became 41 too messy, particularly when such includes can be inserted at random 42 times by the parser generator. */ 43 44%{ 45 46#include "defs.h" 47#include "gdb_string.h" 48#include "expression.h" 49#include "value.h" 50#include "parser-defs.h" 51#include "language.h" 52#include "f-lang.h" 53#include "bfd.h" /* Required by objfiles.h. */ 54#include "symfile.h" /* Required by objfiles.h. */ 55#include "objfiles.h" /* For have_full_symbols and have_partial_symbols */ 56#include "block.h" 57#include <ctype.h> 58 59/* Remap normal yacc parser interface names (yyparse, yylex, yyerror, etc), 60 as well as gratuitiously global symbol names, so we can have multiple 61 yacc generated parsers in gdb. Note that these are only the variables 62 produced by yacc. If other parser generators (bison, byacc, etc) produce 63 additional global names that conflict at link time, then those parser 64 generators need to be fixed instead of adding those names to this list. */ 65 66#define yymaxdepth f_maxdepth 67#define yyparse f_parse 68#define yylex f_lex 69#define yyerror f_error 70#define yylval f_lval 71#define yychar f_char 72#define yydebug f_debug 73#define yypact f_pact 74#define yyr1 f_r1 75#define yyr2 f_r2 76#define yydef f_def 77#define yychk f_chk 78#define yypgo f_pgo 79#define yyact f_act 80#define yyexca f_exca 81#define yyerrflag f_errflag 82#define yynerrs f_nerrs 83#define yyps f_ps 84#define yypv f_pv 85#define yys f_s 86#define yy_yys f_yys 87#define yystate f_state 88#define yytmp f_tmp 89#define yyv f_v 90#define yy_yyv f_yyv 91#define yyval f_val 92#define yylloc f_lloc 93#define yyreds f_reds /* With YYDEBUG defined */ 94#define yytoks f_toks /* With YYDEBUG defined */ 95#define yyname f_name /* With YYDEBUG defined */ 96#define yyrule f_rule /* With YYDEBUG defined */ 97#define yylhs f_yylhs 98#define yylen f_yylen 99#define yydefred f_yydefred 100#define yydgoto f_yydgoto 101#define yysindex f_yysindex 102#define yyrindex f_yyrindex 103#define yygindex f_yygindex 104#define yytable f_yytable 105#define yycheck f_yycheck 106 107#ifndef YYDEBUG 108#define YYDEBUG 1 /* Default to yydebug support */ 109#endif 110 111#define YYFPRINTF parser_fprintf 112 113int yyparse (void); 114 115static int yylex (void); 116 117void yyerror (char *); 118 119static void growbuf_by_size (int); 120 121static int match_string_literal (void); 122 123%} 124 125/* Although the yacc "value" of an expression is not used, 126 since the result is stored in the structure being created, 127 other node types do have values. */ 128 129%union 130 { 131 LONGEST lval; 132 struct { 133 LONGEST val; 134 struct type *type; 135 } typed_val; 136 DOUBLEST dval; 137 struct symbol *sym; 138 struct type *tval; 139 struct stoken sval; 140 struct ttype tsym; 141 struct symtoken ssym; 142 int voidval; 143 struct block *bval; 144 enum exp_opcode opcode; 145 struct internalvar *ivar; 146 147 struct type **tvec; 148 int *ivec; 149 } 150 151%{ 152/* YYSTYPE gets defined by %union */ 153static int parse_number (char *, int, int, YYSTYPE *); 154%} 155 156%type <voidval> exp type_exp start variable 157%type <tval> type typebase 158%type <tvec> nonempty_typelist 159/* %type <bval> block */ 160 161/* Fancy type parsing. */ 162%type <voidval> func_mod direct_abs_decl abs_decl 163%type <tval> ptype 164 165%token <typed_val> INT 166%token <dval> FLOAT 167 168/* Both NAME and TYPENAME tokens represent symbols in the input, 169 and both convey their data as strings. 170 But a TYPENAME is a string that happens to be defined as a typedef 171 or builtin type name (such as int or char) 172 and a NAME is any other symbol. 173 Contexts where this distinction is not important can use the 174 nonterminal "name", which matches either NAME or TYPENAME. */ 175 176%token <sval> STRING_LITERAL 177%token <lval> BOOLEAN_LITERAL 178%token <ssym> NAME 179%token <tsym> TYPENAME 180%type <sval> name 181%type <ssym> name_not_typename 182%type <tsym> typename 183 184/* A NAME_OR_INT is a symbol which is not known in the symbol table, 185 but which would parse as a valid number in the current input radix. 186 E.g. "c" when input_radix==16. Depending on the parse, it will be 187 turned into a name or into a number. */ 188 189%token <ssym> NAME_OR_INT 190 191%token SIZEOF 192%token ERROR 193 194/* Special type cases, put in to allow the parser to distinguish different 195 legal basetypes. */ 196%token INT_KEYWORD INT_S2_KEYWORD LOGICAL_S1_KEYWORD LOGICAL_S2_KEYWORD 197%token LOGICAL_KEYWORD REAL_KEYWORD REAL_S8_KEYWORD REAL_S16_KEYWORD 198%token COMPLEX_S8_KEYWORD COMPLEX_S16_KEYWORD COMPLEX_S32_KEYWORD 199%token BOOL_AND BOOL_OR BOOL_NOT 200%token <lval> CHARACTER 201 202%token <voidval> VARIABLE 203 204%token <opcode> ASSIGN_MODIFY 205 206%left ',' 207%left ABOVE_COMMA 208%right '=' ASSIGN_MODIFY 209%right '?' 210%left BOOL_OR 211%right BOOL_NOT 212%left BOOL_AND 213%left '|' 214%left '^' 215%left '&' 216%left EQUAL NOTEQUAL 217%left LESSTHAN GREATERTHAN LEQ GEQ 218%left LSH RSH 219%left '@' 220%left '+' '-' 221%left '*' '/' '%' 222%right UNARY 223%right '(' 224 225 226%% 227 228start : exp 229 | type_exp 230 ; 231 232type_exp: type 233 { write_exp_elt_opcode(OP_TYPE); 234 write_exp_elt_type($1); 235 write_exp_elt_opcode(OP_TYPE); } 236 ; 237 238exp : '(' exp ')' 239 { } 240 ; 241 242/* Expressions, not including the comma operator. */ 243exp : '*' exp %prec UNARY 244 { write_exp_elt_opcode (UNOP_IND); } 245 ; 246 247exp : '&' exp %prec UNARY 248 { write_exp_elt_opcode (UNOP_ADDR); } 249 ; 250 251exp : '-' exp %prec UNARY 252 { write_exp_elt_opcode (UNOP_NEG); } 253 ; 254 255exp : BOOL_NOT exp %prec UNARY 256 { write_exp_elt_opcode (UNOP_LOGICAL_NOT); } 257 ; 258 259exp : '~' exp %prec UNARY 260 { write_exp_elt_opcode (UNOP_COMPLEMENT); } 261 ; 262 263exp : SIZEOF exp %prec UNARY 264 { write_exp_elt_opcode (UNOP_SIZEOF); } 265 ; 266 267/* No more explicit array operators, we treat everything in F77 as 268 a function call. The disambiguation as to whether we are 269 doing a subscript operation or a function call is done 270 later in eval.c. */ 271 272exp : exp '(' 273 { start_arglist (); } 274 arglist ')' 275 { write_exp_elt_opcode (OP_F77_UNDETERMINED_ARGLIST); 276 write_exp_elt_longcst ((LONGEST) end_arglist ()); 277 write_exp_elt_opcode (OP_F77_UNDETERMINED_ARGLIST); } 278 ; 279 280arglist : 281 ; 282 283arglist : exp 284 { arglist_len = 1; } 285 ; 286 287arglist : substring 288 { arglist_len = 2;} 289 ; 290 291arglist : arglist ',' exp %prec ABOVE_COMMA 292 { arglist_len++; } 293 ; 294 295substring: exp ':' exp %prec ABOVE_COMMA 296 { } 297 ; 298 299 300complexnum: exp ',' exp 301 { } 302 ; 303 304exp : '(' complexnum ')' 305 { write_exp_elt_opcode(OP_COMPLEX); } 306 ; 307 308exp : '(' type ')' exp %prec UNARY 309 { write_exp_elt_opcode (UNOP_CAST); 310 write_exp_elt_type ($2); 311 write_exp_elt_opcode (UNOP_CAST); } 312 ; 313 314/* Binary operators in order of decreasing precedence. */ 315 316exp : exp '@' exp 317 { write_exp_elt_opcode (BINOP_REPEAT); } 318 ; 319 320exp : exp '*' exp 321 { write_exp_elt_opcode (BINOP_MUL); } 322 ; 323 324exp : exp '/' exp 325 { write_exp_elt_opcode (BINOP_DIV); } 326 ; 327 328exp : exp '%' exp 329 { write_exp_elt_opcode (BINOP_REM); } 330 ; 331 332exp : exp '+' exp 333 { write_exp_elt_opcode (BINOP_ADD); } 334 ; 335 336exp : exp '-' exp 337 { write_exp_elt_opcode (BINOP_SUB); } 338 ; 339 340exp : exp LSH exp 341 { write_exp_elt_opcode (BINOP_LSH); } 342 ; 343 344exp : exp RSH exp 345 { write_exp_elt_opcode (BINOP_RSH); } 346 ; 347 348exp : exp EQUAL exp 349 { write_exp_elt_opcode (BINOP_EQUAL); } 350 ; 351 352exp : exp NOTEQUAL exp 353 { write_exp_elt_opcode (BINOP_NOTEQUAL); } 354 ; 355 356exp : exp LEQ exp 357 { write_exp_elt_opcode (BINOP_LEQ); } 358 ; 359 360exp : exp GEQ exp 361 { write_exp_elt_opcode (BINOP_GEQ); } 362 ; 363 364exp : exp LESSTHAN exp 365 { write_exp_elt_opcode (BINOP_LESS); } 366 ; 367 368exp : exp GREATERTHAN exp 369 { write_exp_elt_opcode (BINOP_GTR); } 370 ; 371 372exp : exp '&' exp 373 { write_exp_elt_opcode (BINOP_BITWISE_AND); } 374 ; 375 376exp : exp '^' exp 377 { write_exp_elt_opcode (BINOP_BITWISE_XOR); } 378 ; 379 380exp : exp '|' exp 381 { write_exp_elt_opcode (BINOP_BITWISE_IOR); } 382 ; 383 384exp : exp BOOL_AND exp 385 { write_exp_elt_opcode (BINOP_LOGICAL_AND); } 386 ; 387 388 389exp : exp BOOL_OR exp 390 { write_exp_elt_opcode (BINOP_LOGICAL_OR); } 391 ; 392 393exp : exp '=' exp 394 { write_exp_elt_opcode (BINOP_ASSIGN); } 395 ; 396 397exp : exp ASSIGN_MODIFY exp 398 { write_exp_elt_opcode (BINOP_ASSIGN_MODIFY); 399 write_exp_elt_opcode ($2); 400 write_exp_elt_opcode (BINOP_ASSIGN_MODIFY); } 401 ; 402 403exp : INT 404 { write_exp_elt_opcode (OP_LONG); 405 write_exp_elt_type ($1.type); 406 write_exp_elt_longcst ((LONGEST)($1.val)); 407 write_exp_elt_opcode (OP_LONG); } 408 ; 409 410exp : NAME_OR_INT 411 { YYSTYPE val; 412 parse_number ($1.stoken.ptr, $1.stoken.length, 0, &val); 413 write_exp_elt_opcode (OP_LONG); 414 write_exp_elt_type (val.typed_val.type); 415 write_exp_elt_longcst ((LONGEST)val.typed_val.val); 416 write_exp_elt_opcode (OP_LONG); } 417 ; 418 419exp : FLOAT 420 { write_exp_elt_opcode (OP_DOUBLE); 421 write_exp_elt_type (builtin_type_f_real_s8); 422 write_exp_elt_dblcst ($1); 423 write_exp_elt_opcode (OP_DOUBLE); } 424 ; 425 426exp : variable 427 ; 428 429exp : VARIABLE 430 ; 431 432exp : SIZEOF '(' type ')' %prec UNARY 433 { write_exp_elt_opcode (OP_LONG); 434 write_exp_elt_type (builtin_type_f_integer); 435 CHECK_TYPEDEF ($3); 436 write_exp_elt_longcst ((LONGEST) TYPE_LENGTH ($3)); 437 write_exp_elt_opcode (OP_LONG); } 438 ; 439 440exp : BOOLEAN_LITERAL 441 { write_exp_elt_opcode (OP_BOOL); 442 write_exp_elt_longcst ((LONGEST) $1); 443 write_exp_elt_opcode (OP_BOOL); 444 } 445 ; 446 447exp : STRING_LITERAL 448 { 449 write_exp_elt_opcode (OP_STRING); 450 write_exp_string ($1); 451 write_exp_elt_opcode (OP_STRING); 452 } 453 ; 454 455variable: name_not_typename 456 { struct symbol *sym = $1.sym; 457 458 if (sym) 459 { 460 if (symbol_read_needs_frame (sym)) 461 { 462 if (innermost_block == 0 || 463 contained_in (block_found, 464 innermost_block)) 465 innermost_block = block_found; 466 } 467 write_exp_elt_opcode (OP_VAR_VALUE); 468 /* We want to use the selected frame, not 469 another more inner frame which happens to 470 be in the same block. */ 471 write_exp_elt_block (NULL); 472 write_exp_elt_sym (sym); 473 write_exp_elt_opcode (OP_VAR_VALUE); 474 break; 475 } 476 else 477 { 478 struct minimal_symbol *msymbol; 479 char *arg = copy_name ($1.stoken); 480 481 msymbol = 482 lookup_minimal_symbol (arg, NULL, NULL); 483 if (msymbol != NULL) 484 { 485 write_exp_msymbol (msymbol, 486 lookup_function_type (builtin_type_int), 487 builtin_type_int); 488 } 489 else if (!have_full_symbols () && !have_partial_symbols ()) 490 error ("No symbol table is loaded. Use the \"file\" command."); 491 else 492 error ("No symbol \"%s\" in current context.", 493 copy_name ($1.stoken)); 494 } 495 } 496 ; 497 498 499type : ptype 500 ; 501 502ptype : typebase 503 | typebase abs_decl 504 { 505 /* This is where the interesting stuff happens. */ 506 int done = 0; 507 int array_size; 508 struct type *follow_type = $1; 509 struct type *range_type; 510 511 while (!done) 512 switch (pop_type ()) 513 { 514 case tp_end: 515 done = 1; 516 break; 517 case tp_pointer: 518 follow_type = lookup_pointer_type (follow_type); 519 break; 520 case tp_reference: 521 follow_type = lookup_reference_type (follow_type); 522 break; 523 case tp_array: 524 array_size = pop_type_int (); 525 if (array_size != -1) 526 { 527 range_type = 528 create_range_type ((struct type *) NULL, 529 builtin_type_f_integer, 0, 530 array_size - 1); 531 follow_type = 532 create_array_type ((struct type *) NULL, 533 follow_type, range_type); 534 } 535 else 536 follow_type = lookup_pointer_type (follow_type); 537 break; 538 case tp_function: 539 follow_type = lookup_function_type (follow_type); 540 break; 541 } 542 $$ = follow_type; 543 } 544 ; 545 546abs_decl: '*' 547 { push_type (tp_pointer); $$ = 0; } 548 | '*' abs_decl 549 { push_type (tp_pointer); $$ = $2; } 550 | '&' 551 { push_type (tp_reference); $$ = 0; } 552 | '&' abs_decl 553 { push_type (tp_reference); $$ = $2; } 554 | direct_abs_decl 555 ; 556 557direct_abs_decl: '(' abs_decl ')' 558 { $$ = $2; } 559 | direct_abs_decl func_mod 560 { push_type (tp_function); } 561 | func_mod 562 { push_type (tp_function); } 563 ; 564 565func_mod: '(' ')' 566 { $$ = 0; } 567 | '(' nonempty_typelist ')' 568 { free ($2); $$ = 0; } 569 ; 570 571typebase /* Implements (approximately): (type-qualifier)* type-specifier */ 572 : TYPENAME 573 { $$ = $1.type; } 574 | INT_KEYWORD 575 { $$ = builtin_type_f_integer; } 576 | INT_S2_KEYWORD 577 { $$ = builtin_type_f_integer_s2; } 578 | CHARACTER 579 { $$ = builtin_type_f_character; } 580 | LOGICAL_KEYWORD 581 { $$ = builtin_type_f_logical;} 582 | LOGICAL_S2_KEYWORD 583 { $$ = builtin_type_f_logical_s2;} 584 | LOGICAL_S1_KEYWORD 585 { $$ = builtin_type_f_logical_s1;} 586 | REAL_KEYWORD 587 { $$ = builtin_type_f_real;} 588 | REAL_S8_KEYWORD 589 { $$ = builtin_type_f_real_s8;} 590 | REAL_S16_KEYWORD 591 { $$ = builtin_type_f_real_s16;} 592 | COMPLEX_S8_KEYWORD 593 { $$ = builtin_type_f_complex_s8;} 594 | COMPLEX_S16_KEYWORD 595 { $$ = builtin_type_f_complex_s16;} 596 | COMPLEX_S32_KEYWORD 597 { $$ = builtin_type_f_complex_s32;} 598 ; 599 600typename: TYPENAME 601 ; 602 603nonempty_typelist 604 : type 605 { $$ = (struct type **) malloc (sizeof (struct type *) * 2); 606 $<ivec>$[0] = 1; /* Number of types in vector */ 607 $$[1] = $1; 608 } 609 | nonempty_typelist ',' type 610 { int len = sizeof (struct type *) * (++($<ivec>1[0]) + 1); 611 $$ = (struct type **) realloc ((char *) $1, len); 612 $$[$<ivec>$[0]] = $3; 613 } 614 ; 615 616name : NAME 617 { $$ = $1.stoken; } 618 | TYPENAME 619 { $$ = $1.stoken; } 620 | NAME_OR_INT 621 { $$ = $1.stoken; } 622 ; 623 624name_not_typename : NAME 625/* These would be useful if name_not_typename was useful, but it is just 626 a fake for "variable", so these cause reduce/reduce conflicts because 627 the parser can't tell whether NAME_OR_INT is a name_not_typename (=variable, 628 =exp) or just an exp. If name_not_typename was ever used in an lvalue 629 context where only a name could occur, this might be useful. 630 | NAME_OR_INT 631 */ 632 ; 633 634%% 635 636/* Take care of parsing a number (anything that starts with a digit). 637 Set yylval and return the token type; update lexptr. 638 LEN is the number of characters in it. */ 639 640/*** Needs some error checking for the float case ***/ 641 642static int 643parse_number (p, len, parsed_float, putithere) 644 char *p; 645 int len; 646 int parsed_float; 647 YYSTYPE *putithere; 648{ 649 LONGEST n = 0; 650 LONGEST prevn = 0; 651 int c; 652 int base = input_radix; 653 int unsigned_p = 0; 654 int long_p = 0; 655 ULONGEST high_bit; 656 struct type *signed_type; 657 struct type *unsigned_type; 658 659 if (parsed_float) 660 { 661 /* It's a float since it contains a point or an exponent. */ 662 /* [dD] is not understood as an exponent by atof, change it to 'e'. */ 663 char *tmp, *tmp2; 664 665 tmp = xstrdup (p); 666 for (tmp2 = tmp; *tmp2; ++tmp2) 667 if (*tmp2 == 'd' || *tmp2 == 'D') 668 *tmp2 = 'e'; 669 putithere->dval = atof (tmp); 670 free (tmp); 671 return FLOAT; 672 } 673 674 /* Handle base-switching prefixes 0x, 0t, 0d, 0 */ 675 if (p[0] == '0') 676 switch (p[1]) 677 { 678 case 'x': 679 case 'X': 680 if (len >= 3) 681 { 682 p += 2; 683 base = 16; 684 len -= 2; 685 } 686 break; 687 688 case 't': 689 case 'T': 690 case 'd': 691 case 'D': 692 if (len >= 3) 693 { 694 p += 2; 695 base = 10; 696 len -= 2; 697 } 698 break; 699 700 default: 701 base = 8; 702 break; 703 } 704 705 while (len-- > 0) 706 { 707 c = *p++; 708 if (isupper (c)) 709 c = tolower (c); 710 if (len == 0 && c == 'l') 711 long_p = 1; 712 else if (len == 0 && c == 'u') 713 unsigned_p = 1; 714 else 715 { 716 int i; 717 if (c >= '0' && c <= '9') 718 i = c - '0'; 719 else if (c >= 'a' && c <= 'f') 720 i = c - 'a' + 10; 721 else 722 return ERROR; /* Char not a digit */ 723 if (i >= base) 724 return ERROR; /* Invalid digit in this base */ 725 n *= base; 726 n += i; 727 } 728 /* Portably test for overflow (only works for nonzero values, so make 729 a second check for zero). */ 730 if ((prevn >= n) && n != 0) 731 unsigned_p=1; /* Try something unsigned */ 732 /* If range checking enabled, portably test for unsigned overflow. */ 733 if (RANGE_CHECK && n != 0) 734 { 735 if ((unsigned_p && (unsigned)prevn >= (unsigned)n)) 736 range_error("Overflow on numeric constant."); 737 } 738 prevn = n; 739 } 740 741 /* If the number is too big to be an int, or it's got an l suffix 742 then it's a long. Work out if this has to be a long by 743 shifting right and and seeing if anything remains, and the 744 target int size is different to the target long size. 745 746 In the expression below, we could have tested 747 (n >> TARGET_INT_BIT) 748 to see if it was zero, 749 but too many compilers warn about that, when ints and longs 750 are the same size. So we shift it twice, with fewer bits 751 each time, for the same result. */ 752 753 if ((TARGET_INT_BIT != TARGET_LONG_BIT 754 && ((n >> 2) >> (TARGET_INT_BIT-2))) /* Avoid shift warning */ 755 || long_p) 756 { 757 high_bit = ((ULONGEST)1) << (TARGET_LONG_BIT-1); 758 unsigned_type = builtin_type_unsigned_long; 759 signed_type = builtin_type_long; 760 } 761 else 762 { 763 high_bit = ((ULONGEST)1) << (TARGET_INT_BIT-1); 764 unsigned_type = builtin_type_unsigned_int; 765 signed_type = builtin_type_int; 766 } 767 768 putithere->typed_val.val = n; 769 770 /* If the high bit of the worked out type is set then this number 771 has to be unsigned. */ 772 773 if (unsigned_p || (n & high_bit)) 774 putithere->typed_val.type = unsigned_type; 775 else 776 putithere->typed_val.type = signed_type; 777 778 return INT; 779} 780 781struct token 782{ 783 char *operator; 784 int token; 785 enum exp_opcode opcode; 786}; 787 788static const struct token dot_ops[] = 789{ 790 { ".and.", BOOL_AND, BINOP_END }, 791 { ".AND.", BOOL_AND, BINOP_END }, 792 { ".or.", BOOL_OR, BINOP_END }, 793 { ".OR.", BOOL_OR, BINOP_END }, 794 { ".not.", BOOL_NOT, BINOP_END }, 795 { ".NOT.", BOOL_NOT, BINOP_END }, 796 { ".eq.", EQUAL, BINOP_END }, 797 { ".EQ.", EQUAL, BINOP_END }, 798 { ".eqv.", EQUAL, BINOP_END }, 799 { ".NEQV.", NOTEQUAL, BINOP_END }, 800 { ".neqv.", NOTEQUAL, BINOP_END }, 801 { ".EQV.", EQUAL, BINOP_END }, 802 { ".ne.", NOTEQUAL, BINOP_END }, 803 { ".NE.", NOTEQUAL, BINOP_END }, 804 { ".le.", LEQ, BINOP_END }, 805 { ".LE.", LEQ, BINOP_END }, 806 { ".ge.", GEQ, BINOP_END }, 807 { ".GE.", GEQ, BINOP_END }, 808 { ".gt.", GREATERTHAN, BINOP_END }, 809 { ".GT.", GREATERTHAN, BINOP_END }, 810 { ".lt.", LESSTHAN, BINOP_END }, 811 { ".LT.", LESSTHAN, BINOP_END }, 812 { NULL, 0, 0 } 813}; 814 815struct f77_boolean_val 816{ 817 char *name; 818 int value; 819}; 820 821static const struct f77_boolean_val boolean_values[] = 822{ 823 { ".true.", 1 }, 824 { ".TRUE.", 1 }, 825 { ".false.", 0 }, 826 { ".FALSE.", 0 }, 827 { NULL, 0 } 828}; 829 830static const struct token f77_keywords[] = 831{ 832 { "complex_16", COMPLEX_S16_KEYWORD, BINOP_END }, 833 { "complex_32", COMPLEX_S32_KEYWORD, BINOP_END }, 834 { "character", CHARACTER, BINOP_END }, 835 { "integer_2", INT_S2_KEYWORD, BINOP_END }, 836 { "logical_1", LOGICAL_S1_KEYWORD, BINOP_END }, 837 { "logical_2", LOGICAL_S2_KEYWORD, BINOP_END }, 838 { "complex_8", COMPLEX_S8_KEYWORD, BINOP_END }, 839 { "integer", INT_KEYWORD, BINOP_END }, 840 { "logical", LOGICAL_KEYWORD, BINOP_END }, 841 { "real_16", REAL_S16_KEYWORD, BINOP_END }, 842 { "complex", COMPLEX_S8_KEYWORD, BINOP_END }, 843 { "sizeof", SIZEOF, BINOP_END }, 844 { "real_8", REAL_S8_KEYWORD, BINOP_END }, 845 { "real", REAL_KEYWORD, BINOP_END }, 846 { NULL, 0, 0 } 847}; 848 849/* Implementation of a dynamically expandable buffer for processing input 850 characters acquired through lexptr and building a value to return in 851 yylval. Ripped off from ch-exp.y */ 852 853static char *tempbuf; /* Current buffer contents */ 854static int tempbufsize; /* Size of allocated buffer */ 855static int tempbufindex; /* Current index into buffer */ 856 857#define GROWBY_MIN_SIZE 64 /* Minimum amount to grow buffer by */ 858 859#define CHECKBUF(size) \ 860 do { \ 861 if (tempbufindex + (size) >= tempbufsize) \ 862 { \ 863 growbuf_by_size (size); \ 864 } \ 865 } while (0); 866 867 868/* Grow the static temp buffer if necessary, including allocating the first one 869 on demand. */ 870 871static void 872growbuf_by_size (count) 873 int count; 874{ 875 int growby; 876 877 growby = max (count, GROWBY_MIN_SIZE); 878 tempbufsize += growby; 879 if (tempbuf == NULL) 880 tempbuf = (char *) malloc (tempbufsize); 881 else 882 tempbuf = (char *) realloc (tempbuf, tempbufsize); 883} 884 885/* Blatantly ripped off from ch-exp.y. This routine recognizes F77 886 string-literals. 887 888 Recognize a string literal. A string literal is a nonzero sequence 889 of characters enclosed in matching single quotes, except that 890 a single character inside single quotes is a character literal, which 891 we reject as a string literal. To embed the terminator character inside 892 a string, it is simply doubled (I.E. 'this''is''one''string') */ 893 894static int 895match_string_literal () 896{ 897 char *tokptr = lexptr; 898 899 for (tempbufindex = 0, tokptr++; *tokptr != '\0'; tokptr++) 900 { 901 CHECKBUF (1); 902 if (*tokptr == *lexptr) 903 { 904 if (*(tokptr + 1) == *lexptr) 905 tokptr++; 906 else 907 break; 908 } 909 tempbuf[tempbufindex++] = *tokptr; 910 } 911 if (*tokptr == '\0' /* no terminator */ 912 || tempbufindex == 0) /* no string */ 913 return 0; 914 else 915 { 916 tempbuf[tempbufindex] = '\0'; 917 yylval.sval.ptr = tempbuf; 918 yylval.sval.length = tempbufindex; 919 lexptr = ++tokptr; 920 return STRING_LITERAL; 921 } 922} 923 924/* Read one token, getting characters through lexptr. */ 925 926static int 927yylex () 928{ 929 int c; 930 int namelen; 931 unsigned int i,token; 932 char *tokstart; 933 934 retry: 935 936 prev_lexptr = lexptr; 937 938 tokstart = lexptr; 939 940 /* First of all, let us make sure we are not dealing with the 941 special tokens .true. and .false. which evaluate to 1 and 0. */ 942 943 if (*lexptr == '.') 944 { 945 for (i = 0; boolean_values[i].name != NULL; i++) 946 { 947 if (strncmp (tokstart, boolean_values[i].name, 948 strlen (boolean_values[i].name)) == 0) 949 { 950 lexptr += strlen (boolean_values[i].name); 951 yylval.lval = boolean_values[i].value; 952 return BOOLEAN_LITERAL; 953 } 954 } 955 } 956 957 /* See if it is a special .foo. operator */ 958 959 for (i = 0; dot_ops[i].operator != NULL; i++) 960 if (strncmp (tokstart, dot_ops[i].operator, strlen (dot_ops[i].operator)) == 0) 961 { 962 lexptr += strlen (dot_ops[i].operator); 963 yylval.opcode = dot_ops[i].opcode; 964 return dot_ops[i].token; 965 } 966 967 switch (c = *tokstart) 968 { 969 case 0: 970 return 0; 971 972 case ' ': 973 case '\t': 974 case '\n': 975 lexptr++; 976 goto retry; 977 978 case '\'': 979 token = match_string_literal (); 980 if (token != 0) 981 return (token); 982 break; 983 984 case '(': 985 paren_depth++; 986 lexptr++; 987 return c; 988 989 case ')': 990 if (paren_depth == 0) 991 return 0; 992 paren_depth--; 993 lexptr++; 994 return c; 995 996 case ',': 997 if (comma_terminates && paren_depth == 0) 998 return 0; 999 lexptr++; 1000 return c; 1001 1002 case '.': 1003 /* Might be a floating point number. */ 1004 if (lexptr[1] < '0' || lexptr[1] > '9') 1005 goto symbol; /* Nope, must be a symbol. */ 1006 /* FALL THRU into number case. */ 1007 1008 case '0': 1009 case '1': 1010 case '2': 1011 case '3': 1012 case '4': 1013 case '5': 1014 case '6': 1015 case '7': 1016 case '8': 1017 case '9': 1018 { 1019 /* It's a number. */ 1020 int got_dot = 0, got_e = 0, got_d = 0, toktype; 1021 char *p = tokstart; 1022 int hex = input_radix > 10; 1023 1024 if (c == '0' && (p[1] == 'x' || p[1] == 'X')) 1025 { 1026 p += 2; 1027 hex = 1; 1028 } 1029 else if (c == '0' && (p[1]=='t' || p[1]=='T' || p[1]=='d' || p[1]=='D')) 1030 { 1031 p += 2; 1032 hex = 0; 1033 } 1034 1035 for (;; ++p) 1036 { 1037 if (!hex && !got_e && (*p == 'e' || *p == 'E')) 1038 got_dot = got_e = 1; 1039 else if (!hex && !got_d && (*p == 'd' || *p == 'D')) 1040 got_dot = got_d = 1; 1041 else if (!hex && !got_dot && *p == '.') 1042 got_dot = 1; 1043 else if (((got_e && (p[-1] == 'e' || p[-1] == 'E')) 1044 || (got_d && (p[-1] == 'd' || p[-1] == 'D'))) 1045 && (*p == '-' || *p == '+')) 1046 /* This is the sign of the exponent, not the end of the 1047 number. */ 1048 continue; 1049 /* We will take any letters or digits. parse_number will 1050 complain if past the radix, or if L or U are not final. */ 1051 else if ((*p < '0' || *p > '9') 1052 && ((*p < 'a' || *p > 'z') 1053 && (*p < 'A' || *p > 'Z'))) 1054 break; 1055 } 1056 toktype = parse_number (tokstart, p - tokstart, got_dot|got_e|got_d, 1057 &yylval); 1058 if (toktype == ERROR) 1059 { 1060 char *err_copy = (char *) alloca (p - tokstart + 1); 1061 1062 memcpy (err_copy, tokstart, p - tokstart); 1063 err_copy[p - tokstart] = 0; 1064 error ("Invalid number \"%s\".", err_copy); 1065 } 1066 lexptr = p; 1067 return toktype; 1068 } 1069 1070 case '+': 1071 case '-': 1072 case '*': 1073 case '/': 1074 case '%': 1075 case '|': 1076 case '&': 1077 case '^': 1078 case '~': 1079 case '!': 1080 case '@': 1081 case '<': 1082 case '>': 1083 case '[': 1084 case ']': 1085 case '?': 1086 case ':': 1087 case '=': 1088 case '{': 1089 case '}': 1090 symbol: 1091 lexptr++; 1092 return c; 1093 } 1094 1095 if (!(c == '_' || c == '$' 1096 || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'))) 1097 /* We must have come across a bad character (e.g. ';'). */ 1098 error ("Invalid character '%c' in expression.", c); 1099 1100 namelen = 0; 1101 for (c = tokstart[namelen]; 1102 (c == '_' || c == '$' || (c >= '0' && c <= '9') 1103 || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')); 1104 c = tokstart[++namelen]); 1105 1106 /* The token "if" terminates the expression and is NOT 1107 removed from the input stream. */ 1108 1109 if (namelen == 2 && tokstart[0] == 'i' && tokstart[1] == 'f') 1110 return 0; 1111 1112 lexptr += namelen; 1113 1114 /* Catch specific keywords. */ 1115 1116 for (i = 0; f77_keywords[i].operator != NULL; i++) 1117 if (strncmp (tokstart, f77_keywords[i].operator, 1118 strlen(f77_keywords[i].operator)) == 0) 1119 { 1120 /* lexptr += strlen(f77_keywords[i].operator); */ 1121 yylval.opcode = f77_keywords[i].opcode; 1122 return f77_keywords[i].token; 1123 } 1124 1125 yylval.sval.ptr = tokstart; 1126 yylval.sval.length = namelen; 1127 1128 if (*tokstart == '$') 1129 { 1130 write_dollar_variable (yylval.sval); 1131 return VARIABLE; 1132 } 1133 1134 /* Use token-type TYPENAME for symbols that happen to be defined 1135 currently as names of types; NAME for other symbols. 1136 The caller is not constrained to care about the distinction. */ 1137 { 1138 char *tmp = copy_name (yylval.sval); 1139 struct symbol *sym; 1140 int is_a_field_of_this = 0; 1141 int hextype; 1142 1143 sym = lookup_symbol (tmp, expression_context_block, 1144 VAR_DOMAIN, 1145 current_language->la_language == language_cplus 1146 ? &is_a_field_of_this : NULL, 1147 NULL); 1148 if (sym && SYMBOL_CLASS (sym) == LOC_TYPEDEF) 1149 { 1150 yylval.tsym.type = SYMBOL_TYPE (sym); 1151 return TYPENAME; 1152 } 1153 if ((yylval.tsym.type = lookup_primitive_typename (tmp)) != 0) 1154 return TYPENAME; 1155 1156 /* Input names that aren't symbols but ARE valid hex numbers, 1157 when the input radix permits them, can be names or numbers 1158 depending on the parse. Note we support radixes > 16 here. */ 1159 if (!sym 1160 && ((tokstart[0] >= 'a' && tokstart[0] < 'a' + input_radix - 10) 1161 || (tokstart[0] >= 'A' && tokstart[0] < 'A' + input_radix - 10))) 1162 { 1163 YYSTYPE newlval; /* Its value is ignored. */ 1164 hextype = parse_number (tokstart, namelen, 0, &newlval); 1165 if (hextype == INT) 1166 { 1167 yylval.ssym.sym = sym; 1168 yylval.ssym.is_a_field_of_this = is_a_field_of_this; 1169 return NAME_OR_INT; 1170 } 1171 } 1172 1173 /* Any other kind of symbol */ 1174 yylval.ssym.sym = sym; 1175 yylval.ssym.is_a_field_of_this = is_a_field_of_this; 1176 return NAME; 1177 } 1178} 1179 1180void 1181yyerror (msg) 1182 char *msg; 1183{ 1184 if (prev_lexptr) 1185 lexptr = prev_lexptr; 1186 1187 error ("A %s in expression, near `%s'.", (msg ? msg : "error"), lexptr); 1188} 1189