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