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