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