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