1 /* 2 * Copyright (c) 1980 Regents of the University of California. 3 * All rights reserved. The Berkeley software License Agreement 4 * specifies the terms and conditions for redistribution. 5 */ 6 7 #ifndef lint 8 static char sccsid[] = "@(#)lex.c 5.3 (Berkeley) 01/07/86"; 9 #endif not lint 10 11 /* 12 * lex.c 13 * 14 * Lexical scanner routines for the f77 compiler, pass 1, 4.2 BSD. 15 * 16 * University of Utah CS Dept modification history: 17 * 18 * $Log: lex.c,v $ 19 * Revision 5.4 86/01/07 14:01:13 donn 20 * Fix the scanning for character constants in gettok() so that it handles 21 * the case when an error has occurred and there is no closing quote. 22 * 23 * Revision 5.3 85/11/25 00:24:06 donn 24 * 4.3 beta 25 * 26 * Revision 5.2 85/08/10 04:45:41 donn 27 * Jerry Berkman's changes to ifdef 66 code and handle -r8/double flag. 28 * 29 * Revision 5.1 85/08/10 03:48:20 donn 30 * 4.3 alpha 31 * 32 * Revision 1.2 84/10/27 02:20:09 donn 33 * Fixed bug where the input file and the name field of the include file 34 * structure shared -- when the input file name was freed, the include file 35 * name got stomped on, leading to peculiar error messages. 36 * 37 */ 38 39 #include "defs.h" 40 #include "tokdefs.h" 41 42 # define BLANK ' ' 43 # define MYQUOTE (2) 44 # define SEOF 0 45 46 /* card types */ 47 48 # define STEOF 1 49 # define STINITIAL 2 50 # define STCONTINUE 3 51 52 /* lex states */ 53 54 #define NEWSTMT 1 55 #define FIRSTTOKEN 2 56 #define OTHERTOKEN 3 57 #define RETEOS 4 58 59 60 LOCAL int stkey; 61 LOCAL int lastend = 1; 62 ftnint yystno; 63 flag intonly; 64 LOCAL long int stno; 65 LOCAL long int nxtstno; 66 LOCAL int parlev; 67 LOCAL int expcom; 68 LOCAL int expeql; 69 LOCAL char *nextch; 70 LOCAL char *lastch; 71 LOCAL char *nextcd = NULL; 72 LOCAL char *endcd; 73 LOCAL int prevlin; 74 LOCAL int thislin; 75 LOCAL int code; 76 LOCAL int lexstate = NEWSTMT; 77 LOCAL char s[1390]; 78 LOCAL char *send = s+20*66; 79 LOCAL int nincl = 0; 80 LOCAL char *newname = NULL; 81 82 struct Inclfile 83 { 84 struct Inclfile *inclnext; 85 FILEP inclfp; 86 char *inclname; 87 int incllno; 88 char *incllinp; 89 int incllen; 90 int inclcode; 91 ftnint inclstno; 92 } ; 93 94 LOCAL struct Inclfile *inclp = NULL; 95 LOCAL struct Keylist { char *keyname; int keyval; char notinf66; } ; 96 LOCAL struct Punctlist { char punchar; int punval; }; 97 LOCAL struct Fmtlist { char fmtchar; int fmtval; }; 98 LOCAL struct Dotlist { char *dotname; int dotval; }; 99 LOCAL struct Keylist *keystart[26], *keyend[26]; 100 101 102 103 104 inilex(name) 105 char *name; 106 { 107 nincl = 0; 108 inclp = NULL; 109 doinclude(name); 110 lexstate = NEWSTMT; 111 return(NO); 112 } 113 114 115 116 /* throw away the rest of the current line */ 117 flline() 118 { 119 lexstate = RETEOS; 120 } 121 122 123 124 char *lexline(n) 125 int *n; 126 { 127 *n = (lastch - nextch) + 1; 128 return(nextch); 129 } 130 131 132 133 134 135 doinclude(name) 136 char *name; 137 { 138 FILEP fp; 139 struct Inclfile *t; 140 char temp[100]; 141 register char *lastslash, *s; 142 143 if(inclp) 144 { 145 inclp->incllno = thislin; 146 inclp->inclcode = code; 147 inclp->inclstno = nxtstno; 148 if(nextcd) 149 inclp->incllinp = copyn(inclp->incllen = endcd-nextcd , nextcd); 150 else 151 inclp->incllinp = 0; 152 } 153 nextcd = NULL; 154 155 if(++nincl >= MAXINCLUDES) 156 fatal("includes nested too deep"); 157 if(name[0] == '\0') 158 fp = stdin; 159 else if(name[0]=='/' || inclp==NULL) 160 fp = fopen(name, "r"); 161 else { 162 lastslash = NULL; 163 for(s = inclp->inclname ; *s ; ++s) 164 if(*s == '/') 165 lastslash = s; 166 if(lastslash) 167 { 168 *lastslash = '\0'; 169 sprintf(temp, "%s/%s", inclp->inclname, name); 170 *lastslash = '/'; 171 } 172 else 173 strcpy(temp, name); 174 175 if( (fp = fopen(temp, "r")) == NULL ) 176 { 177 sprintf(temp, "/usr/include/%s", name); 178 fp = fopen(temp, "r"); 179 } 180 if(fp) 181 name = copys(temp); 182 } 183 184 if( fp ) 185 { 186 t = inclp; 187 inclp = ALLOC(Inclfile); 188 inclp->inclnext = t; 189 prevlin = thislin = 0; 190 inclp->inclname = name; 191 infname = copys(name); 192 infile = inclp->inclfp = fp; 193 } 194 else 195 { 196 fprintf(diagfile, "Cannot open file %s", name); 197 done(1); 198 } 199 } 200 201 202 203 204 LOCAL popinclude() 205 { 206 struct Inclfile *t; 207 register char *p; 208 register int k; 209 210 if(infile != stdin) 211 clf(&infile); 212 free(infname); 213 214 --nincl; 215 t = inclp->inclnext; 216 free(inclp->inclname); 217 free( (charptr) inclp); 218 inclp = t; 219 if(inclp == NULL) 220 return(NO); 221 222 infile = inclp->inclfp; 223 infname = copys(inclp->inclname); 224 prevlin = thislin = inclp->incllno; 225 code = inclp->inclcode; 226 stno = nxtstno = inclp->inclstno; 227 if(inclp->incllinp) 228 { 229 endcd = nextcd = s; 230 k = inclp->incllen; 231 p = inclp->incllinp; 232 while(--k >= 0) 233 *endcd++ = *p++; 234 free( (charptr) (inclp->incllinp) ); 235 } 236 else 237 nextcd = NULL; 238 return(YES); 239 } 240 241 242 243 244 yylex() 245 { 246 static int tokno; 247 248 switch(lexstate) 249 { 250 case NEWSTMT : /* need a new statement */ 251 if(getcds() == STEOF) 252 return(SEOF); 253 lastend = stkey == SEND; 254 crunch(); 255 tokno = 0; 256 lexstate = FIRSTTOKEN; 257 yystno = stno; 258 stno = nxtstno; 259 toklen = 0; 260 return(SLABEL); 261 262 first: 263 case FIRSTTOKEN : /* first step on a statement */ 264 analyz(); 265 lexstate = OTHERTOKEN; 266 tokno = 1; 267 return(stkey); 268 269 case OTHERTOKEN : /* return next token */ 270 if(nextch > lastch) 271 goto reteos; 272 ++tokno; 273 if( (stkey==SLOGIF || stkey==SELSEIF) && parlev==0 && tokno>3) 274 goto first; 275 276 if(stkey==SASSIGN && tokno==3 && nextch<lastch && 277 nextch[0]=='t' && nextch[1]=='o') 278 { 279 nextch+=2; 280 return(STO); 281 } 282 return(gettok()); 283 284 reteos: 285 case RETEOS: 286 lexstate = NEWSTMT; 287 return(SEOS); 288 } 289 fatali("impossible lexstate %d", lexstate); 290 /* NOTREACHED */ 291 } 292 293 LOCAL getcds() 294 { 295 register char *p, *q; 296 297 if (newname) 298 { 299 free(infname); 300 infname = newname; 301 newname = NULL; 302 } 303 304 top: 305 if(nextcd == NULL) 306 { 307 code = getcd( nextcd = s ); 308 stno = nxtstno; 309 if (newname) 310 { 311 free(infname); 312 infname = newname; 313 newname = NULL; 314 } 315 prevlin = thislin; 316 } 317 if(code == STEOF) 318 if( popinclude() ) 319 goto top; 320 else 321 return(STEOF); 322 323 if(code == STCONTINUE) 324 { 325 if (newname) 326 { 327 free(infname); 328 infname = newname; 329 newname = NULL; 330 } 331 lineno = thislin; 332 err("illegal continuation card ignored"); 333 nextcd = NULL; 334 goto top; 335 } 336 337 if(nextcd > s) 338 { 339 q = nextcd; 340 p = s; 341 while(q < endcd) 342 *p++ = *q++; 343 endcd = p; 344 } 345 for(nextcd = endcd ; 346 nextcd+66<=send && (code = getcd(nextcd))==STCONTINUE ; 347 nextcd = endcd ) 348 ; 349 nextch = s; 350 lastch = nextcd - 1; 351 if(nextcd >= send) 352 nextcd = NULL; 353 lineno = prevlin; 354 prevlin = thislin; 355 return(STINITIAL); 356 } 357 358 LOCAL getcd(b) 359 register char *b; 360 { 361 register int c; 362 register char *p, *bend; 363 int speclin; 364 static char a[6]; 365 static char *aend = a+6; 366 int num; 367 368 top: 369 endcd = b; 370 bend = b+66; 371 speclin = NO; 372 373 if( (c = getc(infile)) == '&') 374 { 375 a[0] = BLANK; 376 a[5] = 'x'; 377 speclin = YES; 378 bend = send; 379 } 380 else if(c=='c' || c=='C' || c=='*') 381 { 382 while( (c = getc(infile)) != '\n') 383 if(c == EOF) 384 return(STEOF); 385 ++thislin; 386 goto top; 387 } 388 else if(c == '#') 389 { 390 c = getc(infile); 391 while (c == BLANK || c == '\t') 392 c = getc(infile); 393 394 num = 0; 395 while (isdigit(c)) 396 { 397 num = 10*num + c - '0'; 398 c = getc(infile); 399 } 400 thislin = num - 1; 401 402 while (c == BLANK || c == '\t') 403 c = getc(infile); 404 405 if (c == '"') 406 { 407 char fname[1024]; 408 int len = 0; 409 410 c = getc(infile); 411 while (c != '"' && c != '\n') 412 { 413 fname[len++] = c; 414 c = getc(infile); 415 } 416 fname[len++] = '\0'; 417 418 if (newname) 419 free(newname); 420 newname = (char *) ckalloc(len); 421 strcpy(newname, fname); 422 } 423 424 while (c != '\n') 425 if (c == EOF) 426 return (STEOF); 427 else 428 c = getc(infile); 429 goto top; 430 } 431 432 else if(c != EOF) 433 { 434 /* a tab in columns 1-6 skips to column 7 */ 435 ungetc(c, infile); 436 for(p=a; p<aend && (c=getc(infile)) != '\n' && c!=EOF; ) 437 if(c == '\t') 438 { 439 while(p < aend) 440 *p++ = BLANK; 441 speclin = YES; 442 bend = send; 443 } 444 else 445 *p++ = c; 446 } 447 if(c == EOF) 448 return(STEOF); 449 if(c == '\n') 450 { 451 while(p < aend) 452 *p++ = BLANK; 453 if( ! speclin ) 454 while(endcd < bend) 455 *endcd++ = BLANK; 456 } 457 else { /* read body of line */ 458 while( endcd<bend && (c=getc(infile)) != '\n' && c!=EOF ) 459 *endcd++ = c; 460 if(c == EOF) 461 return(STEOF); 462 if(c != '\n') 463 { 464 while( (c=getc(infile)) != '\n') 465 if(c == EOF) 466 return(STEOF); 467 } 468 469 if( ! speclin ) 470 while(endcd < bend) 471 *endcd++ = BLANK; 472 } 473 ++thislin; 474 if( !isspace(a[5]) && a[5]!='0') 475 return(STCONTINUE); 476 for(p=a; p<aend; ++p) 477 if( !isspace(*p) ) goto initline; 478 for(p = b ; p<endcd ; ++p) 479 if( !isspace(*p) ) goto initline; 480 goto top; 481 482 initline: 483 nxtstno = 0; 484 for(p = a ; p<a+5 ; ++p) 485 if( !isspace(*p) ) 486 if(isdigit(*p)) 487 nxtstno = 10*nxtstno + (*p - '0'); 488 else { 489 if (newname) 490 { 491 free(infname); 492 infname = newname; 493 newname = NULL; 494 } 495 lineno = thislin; 496 err("nondigit in statement number field"); 497 nxtstno = 0; 498 break; 499 } 500 return(STINITIAL); 501 } 502 503 LOCAL crunch() 504 { 505 register char *i, *j, *j0, *j1, *prvstr; 506 int ten, nh, quote; 507 508 /* i is the next input character to be looked at 509 j is the next output character */ 510 parlev = 0; 511 expcom = 0; /* exposed ','s */ 512 expeql = 0; /* exposed equal signs */ 513 j = s; 514 prvstr = s; 515 for(i=s ; i<=lastch ; ++i) 516 { 517 if(isspace(*i) ) 518 continue; 519 if(*i=='\'' || *i=='"') 520 { 521 quote = *i; 522 *j = MYQUOTE; /* special marker */ 523 for(;;) 524 { 525 if(++i > lastch) 526 { 527 err("unbalanced quotes; closing quote supplied"); 528 break; 529 } 530 if(*i == quote) 531 if(i<lastch && i[1]==quote) ++i; 532 else break; 533 else if(*i=='\\' && i<lastch) 534 switch(*++i) 535 { 536 case 't': 537 *i = '\t'; break; 538 case 'b': 539 *i = '\b'; break; 540 case 'n': 541 *i = '\n'; break; 542 case 'f': 543 *i = '\f'; break; 544 case 'v': 545 *i = '\v'; break; 546 case '0': 547 *i = '\0'; break; 548 default: 549 break; 550 } 551 *++j = *i; 552 } 553 j[1] = MYQUOTE; 554 j += 2; 555 prvstr = j; 556 } 557 else if( (*i=='h' || *i=='H') && j>prvstr) /* test for Hollerith strings */ 558 { 559 if( ! isdigit(j[-1])) goto copychar; 560 nh = j[-1] - '0'; 561 ten = 10; 562 j1 = prvstr - 1; 563 if (j1<j-5) j1=j-5; 564 for(j0=j-2 ; j0>j1; -- j0) 565 { 566 if( ! isdigit(*j0 ) ) break; 567 nh += ten * (*j0-'0'); 568 ten*=10; 569 } 570 if(j0 <= j1) goto copychar; 571 /* a hollerith must be preceded by a punctuation mark. 572 '*' is possible only as repetition factor in a data statement 573 not, in particular, in character*2h 574 */ 575 576 if( !(*j0=='*'&&s[0]=='d') && *j0!='/' && *j0!='(' && 577 *j0!=',' && *j0!='=' && *j0!='.') 578 goto copychar; 579 if(i+nh > lastch) 580 { 581 erri("%dH too big", nh); 582 nh = lastch - i; 583 } 584 j0[1] = MYQUOTE; /* special marker */ 585 j = j0 + 1; 586 while(nh-- > 0) 587 { 588 if(*++i == '\\') 589 switch(*++i) 590 { 591 case 't': 592 *i = '\t'; break; 593 case 'b': 594 *i = '\b'; break; 595 case 'n': 596 *i = '\n'; break; 597 case 'f': 598 *i = '\f'; break; 599 case '0': 600 *i = '\0'; break; 601 default: 602 break; 603 } 604 *++j = *i; 605 } 606 j[1] = MYQUOTE; 607 j+=2; 608 prvstr = j; 609 } 610 else { 611 if(*i == '(') ++parlev; 612 else if(*i == ')') --parlev; 613 else if(parlev == 0) 614 if(*i == '=') expeql = 1; 615 else if(*i == ',') expcom = 1; 616 copychar: /*not a string or space -- copy, shifting case if necessary */ 617 if(shiftcase && isupper(*i)) 618 *j++ = tolower(*i); 619 else *j++ = *i; 620 } 621 } 622 lastch = j - 1; 623 nextch = s; 624 } 625 626 LOCAL analyz() 627 { 628 register char *i; 629 630 if(parlev != 0) 631 { 632 err("unbalanced parentheses, statement skipped"); 633 stkey = SUNKNOWN; 634 return; 635 } 636 if(nextch+2<=lastch && nextch[0]=='i' && nextch[1]=='f' && nextch[2]=='(') 637 { 638 /* assignment or if statement -- look at character after balancing paren */ 639 parlev = 1; 640 for(i=nextch+3 ; i<=lastch; ++i) 641 if(*i == (MYQUOTE)) 642 { 643 while(*++i != MYQUOTE) 644 ; 645 } 646 else if(*i == '(') 647 ++parlev; 648 else if(*i == ')') 649 { 650 if(--parlev == 0) 651 break; 652 } 653 if(i >= lastch) 654 stkey = SLOGIF; 655 else if(i[1] == '=') 656 stkey = SLET; 657 else if( isdigit(i[1]) ) 658 stkey = SARITHIF; 659 else stkey = SLOGIF; 660 if(stkey != SLET) 661 nextch += 2; 662 } 663 else if(expeql) /* may be an assignment */ 664 { 665 if(expcom && nextch<lastch && 666 nextch[0]=='d' && nextch[1]=='o') 667 { 668 stkey = SDO; 669 nextch += 2; 670 } 671 else stkey = SLET; 672 } 673 /* otherwise search for keyword */ 674 else { 675 stkey = getkwd(); 676 if(stkey==SGOTO && lastch>=nextch) 677 if(nextch[0]=='(') 678 stkey = SCOMPGOTO; 679 else if(isalpha(nextch[0])) 680 stkey = SASGOTO; 681 } 682 parlev = 0; 683 } 684 685 686 687 LOCAL getkwd() 688 { 689 register char *i, *j; 690 register struct Keylist *pk, *pend; 691 int k; 692 693 if(! isalpha(nextch[0]) ) 694 return(SUNKNOWN); 695 k = nextch[0] - 'a'; 696 if(pk = keystart[k]) 697 for(pend = keyend[k] ; pk<=pend ; ++pk ) 698 { 699 i = pk->keyname; 700 j = nextch; 701 while(*++i==*++j && *i!='\0') 702 ; 703 if(*i=='\0' && j<=lastch+1) 704 { 705 nextch = j; 706 #ifdef ONLY66 707 if(no66flag && pk->notinf66) 708 errstr("Not a Fortran 66 keyword: %s", 709 pk->keyname); 710 #endif 711 return(pk->keyval); 712 } 713 } 714 return(SUNKNOWN); 715 } 716 717 718 719 initkey() 720 { 721 extern struct Keylist keys[]; 722 register struct Keylist *p; 723 register int i,j; 724 725 for(i = 0 ; i<26 ; ++i) 726 keystart[i] = NULL; 727 728 for(p = keys ; p->keyname ; ++p) 729 { 730 j = p->keyname[0] - 'a'; 731 if(keystart[j] == NULL) 732 keystart[j] = p; 733 keyend[j] = p; 734 } 735 } 736 737 LOCAL gettok() 738 { 739 int havdot, havexp, havdbl; 740 int radix, val; 741 extern struct Punctlist puncts[]; 742 struct Punctlist *pp; 743 extern struct Fmtlist fmts[]; 744 extern struct Dotlist dots[]; 745 struct Dotlist *pd; 746 747 char *i, *j, *n1, *p; 748 749 if(*nextch == (MYQUOTE)) 750 { 751 ++nextch; 752 p = token; 753 while(nextch <= lastch && *nextch != MYQUOTE) 754 *p++ = *nextch++; 755 ++nextch; 756 toklen = p - token; 757 *p = '\0'; 758 return (SHOLLERITH); 759 } 760 /* 761 if(stkey == SFORMAT) 762 { 763 for(pf = fmts; pf->fmtchar; ++pf) 764 { 765 if(*nextch == pf->fmtchar) 766 { 767 ++nextch; 768 if(pf->fmtval == SLPAR) 769 ++parlev; 770 else if(pf->fmtval == SRPAR) 771 --parlev; 772 return(pf->fmtval); 773 } 774 } 775 if( isdigit(*nextch) ) 776 { 777 p = token; 778 *p++ = *nextch++; 779 while(nextch<=lastch && isdigit(*nextch) ) 780 *p++ = *nextch++; 781 toklen = p - token; 782 *p = '\0'; 783 if(nextch<=lastch && *nextch=='p') 784 { 785 ++nextch; 786 return(SSCALE); 787 } 788 else return(SICON); 789 } 790 if( isalpha(*nextch) ) 791 { 792 p = token; 793 *p++ = *nextch++; 794 while(nextch<=lastch && 795 (*nextch=='.' || isdigit(*nextch) || isalpha(*nextch) )) 796 *p++ = *nextch++; 797 toklen = p - token; 798 *p = '\0'; 799 return(SFIELD); 800 } 801 goto badchar; 802 } 803 /* Not a format statement */ 804 805 if(needkwd) 806 { 807 needkwd = 0; 808 return( getkwd() ); 809 } 810 811 for(pp=puncts; pp->punchar; ++pp) 812 if(*nextch == pp->punchar) 813 { 814 if( (*nextch=='*' || *nextch=='/') && 815 nextch<lastch && nextch[1]==nextch[0]) 816 { 817 if(*nextch == '*') 818 val = SPOWER; 819 else val = SCONCAT; 820 nextch+=2; 821 } 822 else { 823 val = pp->punval; 824 if(val==SLPAR) 825 ++parlev; 826 else if(val==SRPAR) 827 --parlev; 828 ++nextch; 829 } 830 return(val); 831 } 832 if(*nextch == '.') 833 if(nextch >= lastch) goto badchar; 834 else if(isdigit(nextch[1])) goto numconst; 835 else { 836 for(pd=dots ; (j=pd->dotname) ; ++pd) 837 { 838 for(i=nextch+1 ; i<=lastch ; ++i) 839 if(*i != *j) break; 840 else if(*i != '.') ++j; 841 else { 842 nextch = i+1; 843 return(pd->dotval); 844 } 845 } 846 goto badchar; 847 } 848 if( isalpha(*nextch) ) 849 { 850 p = token; 851 *p++ = *nextch++; 852 while(nextch<=lastch) 853 if( isalpha(*nextch) || isdigit(*nextch) ) 854 *p++ = *nextch++; 855 else break; 856 toklen = p - token; 857 *p = '\0'; 858 if(inioctl && nextch<=lastch && *nextch=='=') 859 { 860 ++nextch; 861 return(SNAMEEQ); 862 } 863 if(toklen>8 && eqn(8,token,"function") && isalpha(token[8]) && 864 nextch<lastch && nextch[0]=='(' && 865 (nextch[1]==')' | isalpha(nextch[1])) ) 866 { 867 nextch -= (toklen - 8); 868 return(SFUNCTION); 869 } 870 if(toklen > VL) 871 { 872 char buff[30]; 873 sprintf(buff, "name %s too long, truncated to %d", 874 token, VL); 875 err(buff); 876 toklen = VL; 877 token[VL] = '\0'; 878 } 879 if(toklen==1 && *nextch==MYQUOTE) 880 { 881 switch(token[0]) 882 { 883 case 'z': case 'Z': 884 case 'x': case 'X': 885 radix = 16; break; 886 case 'o': case 'O': 887 radix = 8; break; 888 case 'b': case 'B': 889 radix = 2; break; 890 default: 891 err("bad bit identifier"); 892 return(SNAME); 893 } 894 ++nextch; 895 for(p = token ; *nextch!=MYQUOTE ; ) 896 if ( *nextch == BLANK || *nextch == '\t') 897 nextch++; 898 else 899 { 900 if (isupper(*nextch)) 901 *nextch = tolower(*nextch); 902 if (hextoi(*p++ = *nextch++) >= radix) 903 { 904 err("invalid binary character"); 905 break; 906 } 907 } 908 ++nextch; 909 toklen = p - token; 910 return( radix==16 ? SHEXCON : 911 (radix==8 ? SOCTCON : SBITCON) ); 912 } 913 return(SNAME); 914 } 915 if( ! isdigit(*nextch) ) goto badchar; 916 numconst: 917 havdot = NO; 918 havexp = NO; 919 havdbl = NO; 920 for(n1 = nextch ; nextch<=lastch ; ++nextch) 921 { 922 if(*nextch == '.') 923 if(havdot) break; 924 else if(nextch+2<=lastch && isalpha(nextch[1]) 925 && isalpha(nextch[2])) 926 break; 927 else havdot = YES; 928 else if( !intonly && (*nextch=='d' || *nextch=='e') ) 929 { 930 p = nextch; 931 havexp = YES; 932 if(*nextch == 'd') 933 havdbl = YES; 934 if(nextch<lastch) 935 if(nextch[1]=='+' || nextch[1]=='-') 936 ++nextch; 937 if( (nextch >= lastch) || ! isdigit(*++nextch) ) 938 { 939 nextch = p; 940 havdbl = havexp = NO; 941 break; 942 } 943 for(++nextch ; 944 nextch<=lastch && isdigit(*nextch); 945 ++nextch); 946 break; 947 } 948 else if( ! isdigit(*nextch) ) 949 break; 950 } 951 p = token; 952 i = n1; 953 while(i < nextch) 954 *p++ = *i++; 955 toklen = p - token; 956 *p = '\0'; 957 if(havdbl) return(SDCON); 958 if(havdot || havexp) return( dblflag ? SDCON : SRCON); 959 return(SICON); 960 badchar: 961 s[0] = *nextch++; 962 return(SUNKNOWN); 963 } 964 965 /* KEYWORD AND SPECIAL CHARACTER TABLES 966 */ 967 968 struct Punctlist puncts[ ] = 969 { 970 '(', SLPAR, 971 ')', SRPAR, 972 '=', SEQUALS, 973 ',', SCOMMA, 974 '+', SPLUS, 975 '-', SMINUS, 976 '*', SSTAR, 977 '/', SSLASH, 978 '$', SCURRENCY, 979 ':', SCOLON, 980 0, 0 } ; 981 982 /* 983 LOCAL struct Fmtlist fmts[ ] = 984 { 985 '(', SLPAR, 986 ')', SRPAR, 987 '/', SSLASH, 988 ',', SCOMMA, 989 '-', SMINUS, 990 ':', SCOLON, 991 0, 0 } ; 992 */ 993 994 LOCAL struct Dotlist dots[ ] = 995 { 996 "and.", SAND, 997 "or.", SOR, 998 "not.", SNOT, 999 "true.", STRUE, 1000 "false.", SFALSE, 1001 "eq.", SEQ, 1002 "ne.", SNE, 1003 "lt.", SLT, 1004 "le.", SLE, 1005 "gt.", SGT, 1006 "ge.", SGE, 1007 "neqv.", SNEQV, 1008 "eqv.", SEQV, 1009 0, 0 } ; 1010 1011 LOCAL struct Keylist keys[ ] = 1012 { 1013 { "assign", SASSIGN }, 1014 { "automatic", SAUTOMATIC, YES }, 1015 { "backspace", SBACKSPACE }, 1016 { "blockdata", SBLOCK }, 1017 { "call", SCALL }, 1018 { "character", SCHARACTER, YES }, 1019 { "close", SCLOSE, YES }, 1020 { "common", SCOMMON }, 1021 { "complex", SCOMPLEX }, 1022 { "continue", SCONTINUE }, 1023 { "data", SDATA }, 1024 { "dimension", SDIMENSION }, 1025 { "doubleprecision", SDOUBLE }, 1026 { "doublecomplex", SDCOMPLEX, YES }, 1027 { "elseif", SELSEIF, YES }, 1028 { "else", SELSE, YES }, 1029 { "endfile", SENDFILE }, 1030 { "endif", SENDIF, YES }, 1031 { "end", SEND }, 1032 { "entry", SENTRY, YES }, 1033 { "equivalence", SEQUIV }, 1034 { "external", SEXTERNAL }, 1035 { "format", SFORMAT }, 1036 { "function", SFUNCTION }, 1037 { "goto", SGOTO }, 1038 { "implicit", SIMPLICIT, YES }, 1039 { "include", SINCLUDE, YES }, 1040 { "inquire", SINQUIRE, YES }, 1041 { "intrinsic", SINTRINSIC, YES }, 1042 { "integer", SINTEGER }, 1043 { "logical", SLOGICAL }, 1044 #ifdef NAMELIST 1045 { "namelist", SNAMELIST, YES }, 1046 #endif 1047 { "none", SUNDEFINED, YES }, 1048 { "open", SOPEN, YES }, 1049 { "parameter", SPARAM, YES }, 1050 { "pause", SPAUSE }, 1051 { "print", SPRINT }, 1052 { "program", SPROGRAM, YES }, 1053 { "punch", SPUNCH, YES }, 1054 { "read", SREAD }, 1055 { "real", SREAL }, 1056 { "return", SRETURN }, 1057 { "rewind", SREWIND }, 1058 { "save", SSAVE, YES }, 1059 { "static", SSTATIC, YES }, 1060 { "stop", SSTOP }, 1061 { "subroutine", SSUBROUTINE }, 1062 { "then", STHEN, YES }, 1063 { "undefined", SUNDEFINED, YES }, 1064 { "write", SWRITE }, 1065 { 0, 0 } 1066 }; 1067