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